home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _f3e45554db4aa75b08f2c563ada7a186 < prev    next >
Encoding:
Text File  |  2001-11-16  |  89.7 KB  |  3,356 lines

  1. #! perl -w
  2. # $Revision: 1.39 $
  3.  
  4. # Copyright (c) 2000 Ned Konz. All rights reserved.  This program is free
  5. # software; you can redistribute it and/or modify it under the same terms
  6. # as Perl itself.
  7.  
  8. =head1 NAME
  9.  
  10. Archive::Zip - Provide an interface to ZIP archive files.
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.  use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
  15.  
  16.  my $zip = Archive::Zip->new();
  17.  my $member = $zip->addDirectory( 'dirname/' );
  18.  $member = $zip->addString( 'This is a test', 'stringMember.txt' );
  19.  $member->desiredCompressionMethod( COMPRESSION_DEFLATED );
  20.  $member = $zip->addFile( 'xyz.pl', 'AnotherName.pl' );
  21.  
  22.  die 'write error' if $zip->writeToFileNamed( 'someZip.zip' ) != AZ_OK;
  23.  
  24.  $zip = Archive::Zip->new();
  25.  die 'read error' if $zip->read( 'someZip.zip' ) != AZ_OK;
  26.  
  27.  $member = $zip->memberNamed( 'stringMember.txt' );
  28.  $member->desiredCompressionMethod( COMPRESSION_STORED );
  29.  
  30.  die 'write error' if $zip->writeToFileNamed( 'someOtherZip.zip' ) != AZ_OK;
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. The Archive::Zip module allows a Perl program to create,
  35. manipulate, read, and write Zip archive files.
  36.  
  37. Zip archives can be created, or you can read from existing zip files.
  38. Once created, they can be written to files, streams, or strings.
  39.  
  40. Members can be added, removed, extracted, replaced, rearranged,
  41. and enumerated.
  42. They can also be renamed or have their dates, comments,
  43. or other attributes queried or modified.
  44. Their data can be compressed or uncompressed as needed.
  45. Members can be created from members in existing Zip files,
  46. or from existing directories, files, or strings.
  47.  
  48. This module uses the L<Compress::Zlib|Compress::Zlib> library
  49. to read and write the compressed streams inside the files.
  50.  
  51. =head1 EXPORTS
  52.  
  53. =over 4
  54.  
  55. =item :CONSTANTS
  56.  
  57. Exports the following constants:
  58.  
  59. FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK
  60. GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK
  61. COMPRESSION_STORED COMPRESSION_DEFLATED
  62. IFA_TEXT_FILE_MASK IFA_TEXT_FILE IFA_BINARY_FILE
  63. COMPRESSION_LEVEL_NONE
  64. COMPRESSION_LEVEL_DEFAULT
  65. COMPRESSION_LEVEL_FASTEST
  66. COMPRESSION_LEVEL_BEST_COMPRESSION
  67.  
  68. =item :MISC_CONSTANTS
  69.  
  70. Exports the following constants (only necessary for extending the module):
  71.  
  72. FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST
  73. FA_OS2_HPFS FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS
  74. GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
  75. GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
  76. GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK
  77. DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM
  78. DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST
  79. COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3
  80. COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED
  81. COMPRESSION_DEFLATED_ENHANCED
  82. COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED
  83.  
  84. =item :ERROR_CODES
  85.  
  86. Explained below. Returned from most methods.
  87.  
  88. AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR
  89.  
  90. =back
  91.  
  92. =head1 OBJECT MODEL
  93.  
  94. =head2 Inheritance
  95.  
  96.  Exporter
  97.     Archive::Zip                            Common base class, has defs.
  98.         Archive::Zip::Archive               A Zip archive.
  99.         Archive::Zip::Member                Abstract superclass for all members.
  100.             Archive::Zip::StringMember      Member made from a string
  101.             Archive::Zip::FileMember        Member made from an external file
  102.                 Archive::Zip::ZipFileMember Member that lives in a zip file
  103.                 Archive::Zip::NewFileMember Member whose data is in a file
  104.             Archive::Zip::DirectoryMember   Member that is a directory
  105.  
  106. =cut
  107.  
  108. # ----------------------------------------------------------------------
  109. # class Archive::Zip
  110. # Note that the package Archive::Zip exists only for exporting and
  111. # sharing constants. Everything else is in another package
  112. # in this file.
  113. # Creation of a new Archive::Zip object actually creates a new object
  114. # of class Archive::Zip::Archive.
  115. # ----------------------------------------------------------------------
  116.  
  117. package Archive::Zip;
  118. require 5.003_96;
  119. use strict;
  120.  
  121. use Carp ();
  122. use IO::File ();
  123. use IO::Seekable ();
  124. use Compress::Zlib ();
  125.  
  126. use vars qw( @ISA @EXPORT_OK %EXPORT_TAGS $VERSION $ChunkSize $ErrorHandler );
  127.  
  128. # This is the size we'll try to read, write, and (de)compress.
  129. # You could set it to something different if you had lots of memory
  130. # and needed more speed.
  131. $ChunkSize = 32768;
  132.  
  133. $ErrorHandler = \&Carp::carp;
  134.  
  135. # BEGIN block is necessary here so that other modules can use the constants.
  136. BEGIN
  137. {
  138.     require Exporter;
  139.  
  140.     $VERSION = "0.11";
  141.     @ISA = qw( Exporter );
  142.  
  143.     my @ConstantNames = qw( FA_MSDOS FA_UNIX GPBF_ENCRYPTED_MASK
  144.     GPBF_DEFLATING_COMPRESSION_MASK GPBF_HAS_DATA_DESCRIPTOR_MASK
  145.     COMPRESSION_STORED COMPRESSION_DEFLATED COMPRESSION_LEVEL_NONE
  146.     COMPRESSION_LEVEL_DEFAULT COMPRESSION_LEVEL_FASTEST
  147.     COMPRESSION_LEVEL_BEST_COMPRESSION IFA_TEXT_FILE_MASK IFA_TEXT_FILE
  148.     IFA_BINARY_FILE );
  149.  
  150.     my @MiscConstantNames = qw( FA_AMIGA FA_VAX_VMS FA_VM_CMS FA_ATARI_ST
  151.     FA_OS2_HPFS FA_MACINTOSH FA_Z_SYSTEM FA_CPM FA_WINDOWS_NTFS
  152.     GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK
  153.     GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK
  154.     GPBF_IS_COMPRESSED_PATCHED_DATA_MASK COMPRESSION_SHRUNK
  155.     DEFLATING_COMPRESSION_NORMAL DEFLATING_COMPRESSION_MAXIMUM
  156.     DEFLATING_COMPRESSION_FAST DEFLATING_COMPRESSION_SUPER_FAST
  157.     COMPRESSION_REDUCED_1 COMPRESSION_REDUCED_2 COMPRESSION_REDUCED_3
  158.     COMPRESSION_REDUCED_4 COMPRESSION_IMPLODED COMPRESSION_TOKENIZED
  159.     COMPRESSION_DEFLATED_ENHANCED
  160.     COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED );
  161.  
  162.     my @ErrorCodeNames = qw( AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR
  163.     AZ_IO_ERROR );
  164.  
  165.     my @PKZipConstantNames = qw( SIGNATURE_FORMAT SIGNATURE_LENGTH
  166.     LOCAL_FILE_HEADER_SIGNATURE LOCAL_FILE_HEADER_FORMAT
  167.     LOCAL_FILE_HEADER_LENGTH DATA_DESCRIPTOR_FORMAT DATA_DESCRIPTOR_LENGTH
  168.     CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
  169.     CENTRAL_DIRECTORY_FILE_HEADER_FORMAT CENTRAL_DIRECTORY_FILE_HEADER_LENGTH
  170.     END_OF_CENTRAL_DIRECTORY_SIGNATURE
  171.     END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING END_OF_CENTRAL_DIRECTORY_FORMAT
  172.     END_OF_CENTRAL_DIRECTORY_LENGTH );
  173.  
  174.     my @UtilityMethodNames = qw( _error _ioError _formatError
  175.         _subclassResponsibility _binmode _isSeekable _newFileHandle);
  176.  
  177.     @EXPORT_OK = ( 'computeCRC32' );
  178.     %EXPORT_TAGS = ( 'CONSTANTS' => \@ConstantNames,
  179.             'MISC_CONSTANTS' => \@MiscConstantNames,
  180.             'ERROR_CODES' => \@ErrorCodeNames,
  181.             # The following two sets are for internal use only
  182.             'PKZIP_CONSTANTS' => \@PKZipConstantNames,
  183.             'UTILITY_METHODS' => \@UtilityMethodNames );
  184.  
  185.     # Add all the constant names and error code names to @EXPORT_OK
  186.     Exporter::export_ok_tags( 'CONSTANTS', 'ERROR_CODES',
  187.         'PKZIP_CONSTANTS', 'UTILITY_METHODS', 'MISC_CONSTANTS' );
  188. }
  189.  
  190. # ------------------------- begin exportable error codes -------------------
  191.  
  192. =head1 ERROR CODES
  193.  
  194. Many of the methods in Archive::Zip return error codes.
  195. These are implemented as inline subroutines, using the C<use constant> pragma.
  196. They can be imported into your namespace using the C<:CONSTANT>
  197. tag:
  198.  
  199.     use Archive::Zip qw( :CONSTANTS );
  200.     ...
  201.     die "whoops!" if $zip->read( 'myfile.zip' ) != AZ_OK;
  202.  
  203. =over 4
  204.  
  205. =item AZ_OK (0)
  206.  
  207. Everything is fine.
  208.  
  209. =item AZ_STREAM_END (1)
  210.  
  211. The read stream (or central directory) ended normally.
  212.  
  213. =item AZ_ERROR (2)
  214.  
  215. There was some generic kind of error.
  216.  
  217. =item AZ_FORMAT_ERROR (3)
  218.  
  219. There is a format error in a ZIP file being read.
  220.  
  221. =item AZ_IO_ERROR (4)
  222.  
  223. There was an IO error.
  224.  
  225. =back
  226.  
  227. =cut
  228.  
  229. use constant AZ_OK            => 0;
  230. use constant AZ_STREAM_END    => 1;
  231. use constant AZ_ERROR        => 2;
  232. use constant AZ_FORMAT_ERROR => 3;
  233. use constant AZ_IO_ERROR    => 4;
  234.  
  235. # ------------------------- end exportable error codes ---------------------
  236. # ------------------------- begin exportable constants ---------------------
  237.  
  238. # File types
  239. # Values of Archive::Zip::Member->fileAttributeFormat()
  240.  
  241. use constant FA_MSDOS        => 0;
  242. use constant FA_UNIX        => 3;
  243.  
  244. # general-purpose bit flag masks
  245. # Found in Archive::Zip::Member->bitFlag()
  246.  
  247. use constant GPBF_ENCRYPTED_MASK                        => 1 << 0;
  248. use constant GPBF_DEFLATING_COMPRESSION_MASK            => 3 << 1;
  249. use constant GPBF_HAS_DATA_DESCRIPTOR_MASK                => 1 << 3;
  250.  
  251. # deflating compression types, if compressionMethod == COMPRESSION_DEFLATED
  252. # ( Archive::Zip::Member->bitFlag() & GPBF_DEFLATING_COMPRESSION_MASK )
  253.  
  254. use constant DEFLATING_COMPRESSION_NORMAL        => 0 << 1;
  255. use constant DEFLATING_COMPRESSION_MAXIMUM        => 1 << 1;
  256. use constant DEFLATING_COMPRESSION_FAST            => 2 << 1;
  257. use constant DEFLATING_COMPRESSION_SUPER_FAST    => 3 << 1;
  258.  
  259. # compression method
  260.  
  261. =head1 COMPRESSION
  262.  
  263. Archive::Zip allows each member of a ZIP file to be compressed (using
  264. the Deflate algorithm) or uncompressed. Other compression algorithms
  265. that some versions of ZIP have been able to produce are not supported.
  266.  
  267. Each member has two compression methods: the one it's stored as (this
  268. is always COMPRESSION_STORED for string and external file members),
  269. and the one you desire for the member in the zip file.
  270. These can be different, of course, so you can make a zip member that
  271. is not compressed out of one that is, and vice versa.
  272. You can inquire about the current compression and set
  273. the desired compression method:
  274.  
  275.     my $member = $zip->memberNamed( 'xyz.txt' );
  276.     $member->compressionMethod();    # return current compression
  277.     # set to read uncompressed
  278.     $member->desiredCompressionMethod( COMPRESSION_STORED );
  279.     # set to read compressed
  280.     $member->desiredCompressionMethod( COMPRESSION_DEFLATED );
  281.  
  282. There are two different compression methods:
  283.  
  284. =over 4
  285.  
  286. =item COMPRESSION_STORED
  287.  
  288. file is stored (no compression)
  289.  
  290. =item COMPRESSION_DEFLATED
  291.  
  292. file is Deflated
  293.  
  294. =back
  295.  
  296. =head2 Compression Levels
  297.  
  298. If a member's desiredCompressionMethod is COMPRESSION_DEFLATED,
  299. you can choose different compression levels. This choice may
  300. affect the speed of compression and decompression, as well as
  301. the size of the compressed member data.
  302.  
  303.     $member->desiredCompressionLevel( 9 );
  304.  
  305. The levels given can be:
  306.  
  307. =over 4
  308.  
  309. =item 0 or COMPRESSION_LEVEL_NONE
  310.  
  311. This is the same as saying
  312.  
  313.     $member->desiredCompressionMethod( COMPRESSION_STORED );
  314.  
  315. =item 1 .. 9
  316.  
  317. 1 gives the best speed and worst compression, and 9 gives the best
  318. compression and worst speed.
  319.  
  320. =item COMPRESSION_LEVEL_FASTEST
  321.  
  322. This is a synonym for level 1.
  323.  
  324. =item COMPRESSION_LEVEL_BEST_COMPRESSION
  325.  
  326. This is a synonym for level 9.
  327.  
  328. =item COMPRESSION_LEVEL_DEFAULT
  329.  
  330. This gives a good compromise between speed and compression, and is
  331. currently equivalent to 6 (this is in the zlib code).
  332.  
  333. This is the level that will be used if not specified.
  334.  
  335. =back
  336.  
  337. =cut
  338.  
  339. # these two are the only ones supported in this module
  340. use constant COMPRESSION_STORED => 0;    # file is stored (no compression)
  341. use constant COMPRESSION_DEFLATED => 8;    # file is Deflated
  342.  
  343. use constant COMPRESSION_LEVEL_NONE => 0;
  344. use constant COMPRESSION_LEVEL_DEFAULT => -1;
  345. use constant COMPRESSION_LEVEL_FASTEST => 1;
  346. use constant COMPRESSION_LEVEL_BEST_COMPRESSION => 9;
  347.  
  348. # internal file attribute bits
  349. # Found in Archive::Zip::Member::internalFileAttributes()
  350.  
  351. use constant IFA_TEXT_FILE_MASK    => 1;
  352. use constant IFA_TEXT_FILE        => 1;    # file is apparently text
  353. use constant IFA_BINARY_FILE    => 0;
  354.  
  355. # PKZIP file format miscellaneous constants (for internal use only)
  356. use constant SIGNATURE_FORMAT => "V";
  357. use constant SIGNATURE_LENGTH => 4;
  358.  
  359. use constant LOCAL_FILE_HEADER_SIGNATURE    => 0x04034b50;
  360. use constant LOCAL_FILE_HEADER_FORMAT        => "v3 V4 v2";
  361. use constant LOCAL_FILE_HEADER_LENGTH        => 26;
  362.  
  363. use constant DATA_DESCRIPTOR_FORMAT    => "V3";
  364. use constant DATA_DESCRIPTOR_LENGTH    => 12;
  365.  
  366. use constant CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE => 0x02014b50;
  367. use constant CENTRAL_DIRECTORY_FILE_HEADER_FORMAT => "C2 v3 V4 v5 V2";
  368. use constant CENTRAL_DIRECTORY_FILE_HEADER_LENGTH => 42;
  369.  
  370. use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE => 0x06054b50;
  371. use constant END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING => pack( "V",
  372.     END_OF_CENTRAL_DIRECTORY_SIGNATURE );
  373. use constant END_OF_CENTRAL_DIRECTORY_FORMAT => "v4 V2 v";
  374. use constant END_OF_CENTRAL_DIRECTORY_LENGTH => 18;
  375.  
  376. use constant FA_AMIGA        => 1;
  377. use constant FA_VAX_VMS        => 2;
  378. use constant FA_VM_CMS        => 4;
  379. use constant FA_ATARI_ST    => 5;
  380. use constant FA_OS2_HPFS    => 6;
  381. use constant FA_MACINTOSH    => 7;
  382. use constant FA_Z_SYSTEM    => 8;
  383. use constant FA_CPM            => 9;
  384. use constant FA_WINDOWS_NTFS => 10;
  385.  
  386. use constant GPBF_IMPLODING_8K_SLIDING_DICTIONARY_MASK    => 1 << 1;
  387. use constant GPBF_IMPLODING_3_SHANNON_FANO_TREES_MASK    => 1 << 2;
  388. use constant GPBF_IS_COMPRESSED_PATCHED_DATA_MASK        => 1 << 5;
  389.  
  390. # the rest of these are not supported in this module
  391. use constant COMPRESSION_SHRUNK => 1;    # file is Shrunk
  392. use constant COMPRESSION_REDUCED_1 => 2;# file is Reduced CF=1
  393. use constant COMPRESSION_REDUCED_2 => 3;# file is Reduced CF=2
  394. use constant COMPRESSION_REDUCED_3 => 4;# file is Reduced CF=3
  395. use constant COMPRESSION_REDUCED_4 => 5;# file is Reduced CF=4
  396. use constant COMPRESSION_IMPLODED => 6;    # file is Imploded
  397. use constant COMPRESSION_TOKENIZED => 7;# reserved for Tokenizing compr.
  398. use constant COMPRESSION_DEFLATED_ENHANCED => 9; # reserved for enh. Deflating
  399. use constant COMPRESSION_PKWARE_DATA_COMPRESSION_LIBRARY_IMPLODED => 10;
  400.  
  401. # ------------------------- end of exportable constants ---------------------
  402.  
  403. =head1  Archive::Zip methods
  404.  
  405. The Archive::Zip class (and its invisible subclass Archive::Zip::Archive)
  406. implement generic zip file functionality.
  407.  
  408. Creating a new Archive::Zip object actually makes an Archive::Zip::Archive
  409. object, but you don't have to worry about this unless you're subclassing.
  410.  
  411. =cut
  412.  
  413. =head2 Constructor
  414.  
  415. =over 4
  416.  
  417. =cut
  418.  
  419. use constant ZIPARCHIVECLASS     => 'Archive::Zip::Archive';
  420. use constant ZIPMEMBERCLASS        => 'Archive::Zip::Member';
  421.  
  422. #--------------------------------
  423.  
  424. =item new( [$fileName] )
  425.  
  426. Make a new, empty zip archive.
  427.  
  428.     my $zip = Archive::Zip->new();
  429.  
  430. If an additional argument is passed, new() will call read() to read the
  431. contents of an archive:
  432.  
  433.     my $zip = Archive::Zip->new( 'xyz.zip' );
  434.  
  435. If a filename argument is passed and the read fails for any reason, new
  436. will return undef. For this reason, it may be better to call read
  437. separately.
  438.  
  439. =cut
  440.  
  441. sub new    # Archive::Zip
  442. {
  443.     my $class = shift;
  444.     return $class->ZIPARCHIVECLASS->new( @_ );
  445. }
  446.  
  447. =back
  448.  
  449. =head2  Utility Methods
  450.  
  451. These Archive::Zip methods may be called as functions or as object
  452. methods. Do not call them as class methods:
  453.  
  454.     $zip = Archive::Zip->new();
  455.     $crc = Archive::Zip::computeCRC32( 'ghijkl' );    # OK
  456.     $crc = $zip->computeCRC32( 'ghijkl' );            # also OK
  457.  
  458.     $crc = Archive::Zip->computeCRC32( 'ghijkl' );    # NOT OK
  459.  
  460. =over 4
  461.  
  462. =cut
  463.  
  464. #--------------------------------
  465.  
  466. =item Archive::Zip::computeCRC32( $string [, $crc] )
  467.  
  468. This is a utility function that uses the Compress::Zlib CRC
  469. routine to compute a CRC-32.
  470.  
  471. You can get the CRC of a string:
  472.  
  473.     $crc = Archive::Zip::computeCRC32( $string );
  474.  
  475. Or you can compute the running CRC:
  476.  
  477.     $crc = 0;
  478.     $crc = Archive::Zip::computeCRC32( 'abcdef', $crc );
  479.     $crc = Archive::Zip::computeCRC32( 'ghijkl', $crc );
  480.  
  481. =cut
  482.  
  483. sub computeCRC32    # Archive::Zip
  484. {
  485.     my $data = shift;
  486.     $data = shift if ref( $data );    # allow calling as an obj method
  487.     my $crc = shift;
  488.     return Compress::Zlib::crc32( $data, $crc );
  489. }
  490.  
  491. #--------------------------------
  492.  
  493. =item Archive::Zip::setChunkSize( $number )
  494.  
  495. Change chunk size used for reading and writing.
  496. Currently, this defaults to 32K.
  497. This is not exportable, so you must call it like:
  498.  
  499.     Archive::Zip::setChunkSize( 4096 );
  500.  
  501. or as a method on a zip (though this is a global setting).
  502. Returns old chunk size.
  503.  
  504. =cut
  505.  
  506. sub setChunkSize    # Archive::Zip
  507. {
  508.     my $chunkSize = shift;
  509.     $chunkSize = shift if ref( $chunkSize );    # object method on zip?
  510.     my $oldChunkSize = $Archive::Zip::ChunkSize;
  511.     $Archive::Zip::ChunkSize = $chunkSize;
  512.     return $oldChunkSize;
  513. }
  514.  
  515. #--------------------------------
  516.  
  517. =item Archive::Zip::setErrorHandler( \&subroutine )
  518.  
  519. Change the subroutine called with error strings.
  520. This defaults to \&Carp::carp, but you may want to change
  521. it to get the error strings.
  522.  
  523. This is not exportable, so you must call it like:
  524.  
  525.     Archive::Zip::setErrorHandler( \&myErrorHandler );
  526.  
  527. If no error handler is passed, resets handler to default.
  528.  
  529. Returns old error handler.
  530.  
  531. Note that if you call Carp::carp or a similar routine
  532. or if you're chaining to the default error handler
  533. from your error handler, you may want to increment the number
  534. of caller levels that are skipped (do not just set it to a number):
  535.  
  536.     $Carp::CarpLevel++;
  537.  
  538. =cut
  539.  
  540. sub setErrorHandler (&)    # Archive::Zip
  541. {
  542.     my $errorHandler = shift;
  543.     $errorHandler = \&Carp::carp if ! defined( $errorHandler );
  544.     my $oldErrorHandler = $Archive::Zip::ErrorHandler;
  545.     $Archive::Zip::ErrorHandler = $errorHandler;
  546.     return $oldErrorHandler;
  547. }
  548.  
  549. sub _printError    # Archive::Zip
  550. {
  551.     my $string = join( ' ', @_, "\n" );
  552.     my $oldCarpLevel = $Carp::CarpLevel;
  553.     $Carp::CarpLevel += 2;
  554.     &{ $ErrorHandler }( $string );
  555.     $Carp::CarpLevel = $oldCarpLevel;
  556. }
  557.  
  558. # This is called on format errors.
  559. sub _formatError    # Archive::Zip
  560. {
  561.     shift if ref( $_[0] );
  562.     _printError( 'format error:', @_ );
  563.     return AZ_FORMAT_ERROR;
  564. }
  565.  
  566. # This is called on IO errors.
  567. sub _ioError    # Archive::Zip
  568. {
  569.     shift if ref( $_[0] );
  570.     _printError( 'IO error:', @_, ':', $! );
  571.     return AZ_IO_ERROR;
  572. }
  573.  
  574. # This is called on generic errors.
  575. sub _error    # Archive::Zip
  576. {
  577.     shift if ref( $_[0] );
  578.     _printError( 'error:', @_ );
  579.     return AZ_ERROR;
  580. }
  581.  
  582. # Called when a subclass should have implemented
  583. # something but didn't
  584. sub _subclassResponsibility     # Archive::Zip
  585. {
  586.     Carp::croak( "subclass Responsibility\n" );
  587. }
  588.  
  589. # Try to set the given file handle or object into binary mode.
  590. sub _binmode    # Archive::Zip
  591. {
  592.     my $fh = shift;
  593.     return $fh->can( 'binmode' )
  594.         ?    $fh->binmode()
  595.         :    binmode( $fh );
  596. }
  597.  
  598. # Attempt to guess whether file handle is seekable.
  599. sub _isSeekable    # Archive::Zip
  600. {
  601.     my $fh = shift;
  602.     my ($p0, $p1);
  603.     my $seekable = 
  604.         ( $p0 = $fh->tell() ) >= 0
  605.         && $fh->seek( 1, IO::Seekable::SEEK_CUR )
  606.         && ( $p1 = $fh->tell() ) >= 0
  607.         && $p1 == $p0 + 1
  608.         && $fh->seek( -1, IO::Seekable::SEEK_CUR )
  609.         && $fh->tell() == $p0;
  610.     return $seekable;
  611. }
  612.  
  613. # Return an opened IO::Handle
  614. # my ( $status, fh ) = _newFileHandle( 'fileName', 'w' );
  615. # Can take a filename, file handle, or ref to GLOB
  616. # Or, if given something that is a ref but not an IO::Handle,
  617. # passes back the same thing.
  618. sub _newFileHandle    # Archive::Zip
  619. {
  620.     my $fd = shift;
  621.     my $status = 1;
  622.     my $handle = IO::File->new();
  623.  
  624.     if ( ref( $fd ) )
  625.     {
  626.         if ( $fd->isa( 'IO::Handle' ) or $fd->isa( 'GLOB' ) )
  627.         {
  628.             $status = $handle->fdopen( $fd, @_ );
  629.         }
  630.         else
  631.         {
  632.             $handle = $fd;
  633.         }
  634.     }
  635.     else
  636.     {
  637.         $status = $handle->open( $fd, @_ );
  638.     }
  639.  
  640.     return ( $status, $handle );
  641. }
  642.  
  643. =back
  644.  
  645. =cut
  646.  
  647. # ----------------------------------------------------------------------
  648. # class Archive::Zip::Archive (concrete)
  649. # Generic ZIP archive.
  650. # ----------------------------------------------------------------------
  651. package Archive::Zip::Archive;
  652. use File::Path;
  653. use File::Basename;
  654.  
  655. use vars qw( @ISA );
  656. @ISA = qw( Archive::Zip );
  657.  
  658. BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
  659.     :UTILITY_METHODS ) }
  660.  
  661. #--------------------------------
  662. # Note that this returns undef on read errors, else new zip object.
  663.  
  664. sub new    # Archive::Zip::Archive
  665. {
  666.     my $class = shift;
  667.     my $self = bless( {
  668.         'diskNumber' => 0,
  669.         'diskNumberWithStartOfCentralDirectory' => 0,
  670.         'numberOfCentralDirectoriesOnThisDisk' => 0, # shld be # of members
  671.         'numberOfCentralDirectories' => 0,    # shld be # of members
  672.         'centralDirectorySize' => 0,    # must re-compute on write
  673.         'centralDirectoryOffsetWRTStartingDiskNumber' => 0,    # must re-compute
  674.         'zipfileComment' => ''
  675.         }, $class );
  676.     $self->{'members'} = [];
  677.     if ( @_ )
  678.     {
  679.         my $status = $self->read( @_ );
  680.         return $status == AZ_OK ? $self : undef;
  681.     }
  682.     return $self;
  683. }
  684.  
  685. =head2 Accessors
  686.  
  687. =over 4
  688.  
  689. =cut
  690.  
  691. #--------------------------------
  692.  
  693. =item members()
  694.  
  695. Return a copy of my members array
  696.  
  697.     my @members = $zip->members();
  698.  
  699. =cut
  700.  
  701. sub members    # Archive::Zip::Archive
  702. { @{ shift->{'members'} } }
  703.  
  704. #--------------------------------
  705.  
  706. =item numberOfMembers()
  707.  
  708. Return the number of members I have
  709.  
  710. =cut
  711.  
  712. sub numberOfMembers    # Archive::Zip::Archive
  713. { scalar( shift->members() ) }
  714.  
  715. #--------------------------------
  716.  
  717. =item memberNames()
  718.  
  719. Return a list of the (internal) file names of my members
  720.  
  721. =cut
  722.  
  723. sub memberNames    # Archive::Zip::Archive
  724. {
  725.     my $self = shift;
  726.     return map { $_->fileName() } $self->members();
  727. }
  728.  
  729. #--------------------------------
  730.  
  731. =item memberNamed( $string )
  732.  
  733. Return ref to member whose filename equals given filename or undef
  734.  
  735. =cut
  736.  
  737. sub memberNamed    # Archive::Zip::Archive
  738. {
  739.     my ( $self, $fileName ) = @_;
  740.     my ( $retval ) = grep { $_->fileName() eq $fileName } $self->members();
  741.     return $retval;
  742. }
  743.  
  744. #--------------------------------
  745.  
  746. =item membersMatching( $regex )
  747.  
  748. Return array of members whose filenames match given regular
  749. expression in list context.
  750. Returns number of matching members in scalar context.
  751.  
  752.     my @textFileMembers = $zip->membersMatching( '.*\.txt' );
  753.     # or
  754.     my $numberOfTextFiles = $zip->membersMatching( '.*\.txt' );
  755.  
  756. =cut
  757.  
  758. sub membersMatching    # Archive::Zip::Archive
  759. {
  760.     my ( $self, $pattern ) = @_;
  761.     return grep { $_->fileName() =~ /$pattern/ } $self->members();
  762. }
  763.  
  764. #--------------------------------
  765.  
  766. =item diskNumber()
  767.  
  768. Return the disk that I start on.
  769. Not used for writing zips, but might be interesting if you read a zip in.
  770. This had better be 0, as Archive::Zip does not handle multi-volume archives.
  771.  
  772. =cut
  773.  
  774. sub diskNumber    # Archive::Zip::Archive
  775. { shift->{'diskNumber'} }
  776.  
  777. #--------------------------------
  778.  
  779. =item diskNumberWithStartOfCentralDirectory()
  780.  
  781. Return the disk number that holds the beginning of the central directory.
  782. Not used for writing zips, but might be interesting if you read a zip in.
  783. This had better be 0, as Archive::Zip does not handle multi-volume archives.
  784.  
  785. =cut
  786.  
  787. sub diskNumberWithStartOfCentralDirectory    # Archive::Zip::Archive
  788. { shift->{'diskNumberWithStartOfCentralDirectory'} }
  789.  
  790. #--------------------------------
  791.  
  792. =item numberOfCentralDirectoriesOnThisDisk()
  793.  
  794. Return the number of CD structures on this disk.
  795. Not used for writing zips, but might be interesting if you read a zip in.
  796.  
  797. =cut
  798.  
  799. sub numberOfCentralDirectoriesOnThisDisk    # Archive::Zip::Archive
  800. { shift->{'numberOfCentralDirectoriesOnThisDisk'} }
  801.  
  802. #--------------------------------
  803.  
  804. =item numberOfCentralDirectories()
  805.  
  806. Return the number of CD structures in the whole zip.
  807. Not used for writing zips, but might be interesting if you read a zip in.
  808.  
  809. =cut
  810.  
  811. sub numberOfCentralDirectories    # Archive::Zip::Archive
  812. { shift->{'numberOfCentralDirectories'} }
  813.  
  814. #--------------------------------
  815.  
  816. =item centralDirectorySize()
  817.  
  818. Returns central directory size, as read from an external zip file.
  819. Not used for writing zips, but might be interesting if you read a zip in.
  820.  
  821. =cut
  822.  
  823. sub centralDirectorySize    # Archive::Zip::Archive
  824. { shift->{'centralDirectorySize'} }
  825.  
  826. #--------------------------------
  827.  
  828. =item centralDirectoryOffsetWRTStartingDiskNumber()
  829.  
  830. Returns the offset into the zip file where the CD begins.
  831. Not used for writing zips, but might be interesting if you read a zip in.
  832.  
  833. =cut
  834.  
  835. sub centralDirectoryOffsetWRTStartingDiskNumber    # Archive::Zip::Archive
  836. { shift->{'centralDirectoryOffsetWRTStartingDiskNumber'} }
  837.  
  838. #--------------------------------
  839.  
  840. =item zipfileComment( [$string] )
  841.  
  842. Get or set the zipfile comment.
  843. Returns the old comment.
  844.  
  845.     print $zip->zipfileComment();
  846.     $zip->zipfileComment( 'New Comment' );
  847.  
  848. =cut
  849.  
  850. sub zipfileComment    # Archive::Zip::Archive
  851. {
  852.     my $self = shift;
  853.     my $comment = $self->{'zipfileComment'};
  854.     if ( @_ )
  855.     {
  856.         $self->{'zipfileComment'} = shift;
  857.     }
  858.     return $comment;
  859. }
  860.  
  861. =back
  862.  
  863. =head2 Member Operations
  864.  
  865. Various operations on a zip file modify members.
  866. When a member is passed as an argument, you can either use a reference
  867. to the member itself, or the name of a member. Of course, using the
  868. name requires that names be unique within a zip (this is not enforced).
  869.  
  870. =over 4
  871.  
  872. =cut
  873.  
  874. #--------------------------------
  875.  
  876. =item removeMember( $memberOrName )
  877.  
  878. Remove and return the given member, or match its name and remove it.
  879. Returns undef if member name doesn't exist in this Zip.
  880. No-op if member does not belong to this zip.
  881.  
  882. =cut
  883.  
  884. sub removeMember    # Archive::Zip::Archive
  885. {
  886.     my ( $self, $member ) = @_;
  887.     $member = $self->memberNamed( $member ) if ! ref( $member );
  888.     return undef if ! $member;
  889.     my @newMembers = grep { $_ != $member } $self->members();
  890.     $self->{'members'} = \@newMembers;
  891.     return $member;
  892. }
  893.  
  894. #--------------------------------
  895.  
  896. =item replaceMember( $memberOrName, $newMember )
  897.  
  898. Remove and return the given member, or match its name and remove it.
  899. Replace with new member.
  900. Returns undef if member name doesn't exist in this Zip.
  901.  
  902.     my $member1 = $zip->removeMember( 'xyz' );
  903.     my $member2 = $zip->replaceMember( 'abc', $member1 );
  904.     # now, $member2 (named 'abc') is not in $zip,
  905.     # and $member1 (named 'xyz') is, having taken $member2's place.
  906.  
  907. =cut
  908.  
  909. sub replaceMember    # Archive::Zip::Archive
  910. {
  911.     my ( $self, $oldMember, $newMember ) = @_;
  912.     $oldMember = $self->memberNamed( $oldMember ) if ! ref( $oldMember );
  913.     return undef if ! $oldMember;
  914.     my @newMembers
  915.         = map { ( $_ == $oldMember ) ? $newMember : $_ } $self->members();
  916.     $self->{'members'} = \@newMembers;
  917.     return $oldMember;
  918. }
  919.  
  920. #--------------------------------
  921.  
  922. =item extractMember( $memberOrName [, $extractedName ] )
  923.  
  924. Extract the given member, or match its name and extract it.
  925. Returns undef if member doesn't exist in this Zip.
  926. If optional second arg is given, use it as the name of the
  927. extracted member. Otherwise, the internal filename of the member is used
  928. as the name of the extracted file or directory.
  929.  
  930. All necessary directories will be created.
  931.  
  932. Returns C<AZ_OK> on success.
  933.  
  934. =cut
  935.  
  936. sub extractMember    # Archive::Zip::Archive
  937. {
  938.     my $self = shift;
  939.     my $member = shift;
  940.     $member = $self->memberNamed( $member ) if ! ref( $member );
  941.     return _error( 'member not found' ) if !$member;
  942.     my $name = shift;
  943.     $name = $member->fileName() if not $name;
  944.     my $dirName = dirname( $name );
  945.     mkpath( $dirName ) if ( ! -d $dirName );
  946.     return _ioError( "can't create dir $dirName" ) if ( ! -d $dirName );
  947.     return $member->extractToFileNamed( $name, @_ );
  948. }
  949.  
  950. #--------------------------------
  951.  
  952. =item extractMemberWithoutPaths( $memberOrName [, $extractedName ] )
  953.  
  954. Extract the given member, or match its name and extract it.
  955. Does not use path information (extracts into the current directory).
  956. Returns undef if member doesn't exist in this Zip.
  957. If optional second arg is given, use it as the name of the
  958. extracted member (its paths will be deleted too).
  959. Otherwise, the internal filename of the member (minus paths) is used
  960. as the name of the extracted file or directory.
  961.  
  962. Returns C<AZ_OK> on success.
  963.  
  964. =cut
  965.  
  966. sub extractMemberWithoutPaths    # Archive::Zip::Archive
  967. {
  968.     my $self = shift;
  969.     my $member = shift;
  970.     $member = $self->memberNamed( $member ) if ! ref( $member );
  971.     return _error( 'member not found' ) if !$member;
  972.     my $name = shift;
  973.     $name = $member->fileName() if not $name;
  974.     $name = basename( $name );
  975.     return $member->extractToFileNamed( $name, @_ );
  976. }
  977.  
  978. #--------------------------------
  979.  
  980. =item addMember( $member )
  981.  
  982. Append a member (possibly from another zip file) to the zip file.
  983. Returns the new member.
  984. Generally, you will use addFile(), addDirectory(), addString(), or read()
  985. to add members.
  986.  
  987.     # Move member named 'abc' to end of zip:
  988.     my $member = $zip->removeMember( 'abc' );
  989.     $zip->addMember( $member );
  990.  
  991. =cut
  992.  
  993. sub addMember    # Archive::Zip::Archive
  994. {
  995.     my ( $self, $newMember ) = @_;
  996.     push( @{ $self->{'members'} }, $newMember ) if $newMember;
  997.     return $newMember;
  998. }
  999.  
  1000. #--------------------------------
  1001.  
  1002. =item addFile( $fileName [, $newName ] )
  1003.  
  1004. Append a member whose data comes from an external file,
  1005. returning the member or undef.
  1006. The member will have its file name set to the name of the external
  1007. file, and its desiredCompressionMethod set to COMPRESSION_DEFLATED.
  1008. The file attributes and last modification time will be set from the file.
  1009.  
  1010. If the name given does not represent a readable plain file or symbolic link,
  1011. undef will be returned.
  1012.  
  1013. The text mode bit will be set if the contents appears to be text (as returned
  1014. by the C<-T> perl operator).
  1015.  
  1016. The optional second argument sets the internal file name to
  1017. something different than the given $fileName.
  1018.  
  1019. =cut
  1020.  
  1021. sub addFile    # Archive::Zip::Archive
  1022. {
  1023.     my $self = shift;
  1024.     my $fileName = shift;
  1025.     my $newName = shift;
  1026.     my $newMember = $self->ZIPMEMBERCLASS->newFromFile( $fileName );
  1027.     if (defined($newMember))
  1028.     {
  1029.         $self->addMember( $newMember );
  1030.         $newMember->fileName( $newName ) if defined( $newName );
  1031.     }
  1032.     return $newMember;
  1033. }
  1034.  
  1035. #--------------------------------
  1036.  
  1037. =item addString( $stringOrStringRef [, $name] )
  1038.  
  1039. Append a member created from the given string or string reference.
  1040. The name is given by the optional second argument.
  1041. Returns the new member.
  1042.  
  1043. The last modification time will be set to now,
  1044. and the file attributes will be set to permissive defaults.
  1045.  
  1046.     my $member = $zip->addString( 'This is a test', 'test.txt' );
  1047.  
  1048. =cut
  1049.  
  1050. sub addString    # Archive::Zip::Archive
  1051. {
  1052.     my $self = shift;
  1053.     my $newMember = $self->ZIPMEMBERCLASS->newFromString( @_ );
  1054.     return $self->addMember( $newMember );
  1055. }
  1056.  
  1057. #--------------------------------
  1058.  
  1059. =item addDirectory( $directoryName [, $fileName ] )
  1060.  
  1061. Append a member created from the given directory name.
  1062. The directory name does not have to name an existing directory.
  1063. If the named directory exists, the file modification time and permissions
  1064. are set from the existing directory, otherwise they are set to now and
  1065. permissive default permissions.
  1066. The optional second argument sets the name of the archive member
  1067. (which defaults to $directoryName)
  1068.  
  1069. Returns the new member.
  1070.  
  1071. =cut
  1072.  
  1073. sub addDirectory    # Archive::Zip::Archive
  1074. {
  1075.     my ( $self, $name, $newName ) = @_;
  1076.     my $newMember = $self->ZIPMEMBERCLASS->newDirectoryNamed( $name );
  1077.     $self->addMember( $newMember );
  1078.     $newMember->fileName( $newName ) if defined( $newName );
  1079.     return $newMember;
  1080. }
  1081.  
  1082. #--------------------------------
  1083.  
  1084. =item contents( $memberOrMemberName [, $newContents ] )
  1085.  
  1086. Returns the uncompressed data for a particular member, or undef.
  1087.  
  1088.     print "xyz.txt contains " . $zip->contents( 'xyz.txt' );
  1089.  
  1090. Also can change the contents of a member:
  1091.  
  1092.     $zip->contents( 'xyz.txt', 'This is the new contents' );
  1093.  
  1094. =cut
  1095.  
  1096. sub contents    # Archive::Zip::Archive
  1097. {
  1098.     my ( $self, $member, $newContents ) = @_;
  1099.     $member = $self->memberNamed( $member ) if ! ref( $member );
  1100.     return undef if ! $member;
  1101.     return $member->contents( $newContents );
  1102. }
  1103.  
  1104. #--------------------------------
  1105.  
  1106. =item writeToFileNamed( $fileName )
  1107.  
  1108. Write a zip archive to named file.
  1109. Returns C<AZ_OK> on success.
  1110.  
  1111. Note that if you use the same name as an existing
  1112. zip file that you read in, you will clobber ZipFileMembers.
  1113. So instead, write to a different file name, then delete
  1114. the original.
  1115.  
  1116.     my $status = $zip->writeToFileNamed( 'xx.zip' );
  1117.     die "error somewhere" if $status != AZ_OK;
  1118.  
  1119. =cut
  1120.  
  1121. sub writeToFileNamed    # Archive::Zip::Archive
  1122. {
  1123.     my $self = shift;
  1124.     my $fileName = shift;
  1125.     foreach my $member ( $self->members() )
  1126.     {
  1127.         if ( $member->_usesFileNamed( $fileName ) )
  1128.         {
  1129.             return _error("$fileName is needed by member " 
  1130.                     . $member->fileName() 
  1131.                     . "; try renaming output file");
  1132.         }
  1133.     }
  1134.     my ( $status, $fh ) = _newFileHandle( $fileName, 'w' );
  1135.     return _ioError( "Can't open $fileName for write" ) if !$status;
  1136.     my $retval = $self->writeToFileHandle( $fh, 1 );
  1137.     $fh->close();
  1138.     return $retval;
  1139. }
  1140.  
  1141. #--------------------------------
  1142.  
  1143. =item writeToFileHandle( $fileHandle [, $seekable] )
  1144.  
  1145. Write a zip archive to a file handle.
  1146. Return AZ_OK on success.
  1147.  
  1148. The optional second arg tells whether or not to try to seek backwards
  1149. to re-write headers.
  1150. If not provided, it is set by testing seekability. This could fail
  1151. on some operating systems, though.
  1152.  
  1153.     my $fh = IO::File->new( 'someFile.zip', 'w' );
  1154.     $zip->writeToFileHandle( $fh );
  1155.  
  1156. If you pass a file handle that is not seekable (like if you're writing
  1157. to a pipe or a socket), pass a false as the second argument:
  1158.  
  1159.     my $fh = IO::File->new( '| cat > somefile.zip', 'w' );
  1160.     $zip->writeToFileHandle( $fh, 0 );   # fh is not seekable
  1161.  
  1162. =cut
  1163.  
  1164. sub writeToFileHandle    # Archive::Zip::Archive
  1165. {
  1166.     my $self = shift;
  1167.     my $fh = shift;
  1168.     my $fhIsSeekable = @_ ? shift : _isSeekable( $fh );
  1169.     _binmode( $fh );
  1170.  
  1171.     my $offset = 0;
  1172.     foreach my $member ( $self->members() )
  1173.     {
  1174.         $member->{'writeLocalHeaderRelativeOffset'} = $offset;
  1175.         my $retval = $member->_writeToFileHandle( $fh, $fhIsSeekable );
  1176.         $member->endRead();
  1177.         return $retval if $retval != AZ_OK;
  1178.         $offset += $member->_localHeaderSize() + $member->_writeOffset();
  1179.         $offset += $member->hasDataDescriptor() ? DATA_DESCRIPTOR_LENGTH : 0;
  1180.     }
  1181.     $self->{'writeCentralDirectoryOffset'} = $offset;
  1182.     return $self->_writeCentralDirectory( $fh );
  1183. }
  1184.  
  1185. # Returns next signature from given file handle, leaves
  1186. # file handle positioned afterwards.
  1187. # In list context, returns ($status, $signature)
  1188.  
  1189. sub _readSignature    # Archive::Zip::Archive
  1190. {
  1191.     my $self = shift;
  1192.     my $fh = shift;
  1193.     my $fileName = shift;
  1194.     my $signatureData;
  1195.     $fh->read( $signatureData, SIGNATURE_LENGTH )
  1196.         or return _ioError( "reading header signature" );
  1197.     my $signature = unpack( SIGNATURE_FORMAT, $signatureData );
  1198.     my $status = AZ_OK;
  1199.     if ( $signature != CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE
  1200.             and $signature != LOCAL_FILE_HEADER_SIGNATURE
  1201.             and $signature != END_OF_CENTRAL_DIRECTORY_SIGNATURE )
  1202.     {
  1203.         $status = _formatError(
  1204.             sprintf( "bad signature: 0x%08x at offset %d in file \"%s\"",
  1205.                 $signature, $fh->tell() - SIGNATURE_LENGTH, $fileName ) );
  1206.     }
  1207.  
  1208.     return ( $status, $signature );
  1209. }
  1210.  
  1211. # Used only during writing
  1212. sub _writeCentralDirectoryOffset    # Archive::Zip::Archive
  1213. { shift->{'writeCentralDirectoryOffset'} }
  1214.  
  1215. sub _writeEOCDOffset    # Archive::Zip::Archive
  1216. { shift->{'writeEOCDOffset'} }
  1217.  
  1218. # Expects to have _writeEOCDOffset() set
  1219. sub _writeEndOfCentralDirectory    # Archive::Zip::Archive
  1220. {
  1221.     my ( $self, $fh ) = @_;
  1222.  
  1223.     $fh->write( END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING, SIGNATURE_LENGTH )
  1224.         or return _ioError( 'writing EOCD Signature' );
  1225.  
  1226.     my $header = pack( END_OF_CENTRAL_DIRECTORY_FORMAT,
  1227.         0,    # {'diskNumber'},
  1228.         0,    # {'diskNumberWithStartOfCentralDirectory'},
  1229.         $self->numberOfMembers(),    # {'numberOfCentralDirectoriesOnThisDisk'},
  1230.         $self->numberOfMembers(),    # {'numberOfCentralDirectories'},
  1231.         $self->_writeEOCDOffset() - $self->_writeCentralDirectoryOffset(),
  1232.         $self->_writeCentralDirectoryOffset(),
  1233.         length( $self->zipfileComment() )
  1234.      );
  1235.     $fh->write( $header, END_OF_CENTRAL_DIRECTORY_LENGTH )
  1236.         or return _ioError( 'writing EOCD header' );
  1237.     if ( length( $self->zipfileComment() ))
  1238.     {
  1239.         $fh->write( $self->zipfileComment(), length( $self->zipfileComment() ))
  1240.             or return _ioError( 'writing zipfile comment' );
  1241.     }
  1242.     return AZ_OK;
  1243. }
  1244.  
  1245. sub _writeCentralDirectory    # Archive::Zip::Archive
  1246. {
  1247.     my ( $self, $fh ) = @_;
  1248.  
  1249.     my $offset = $self->_writeCentralDirectoryOffset();
  1250.     foreach my $member ( $self->members() )
  1251.     {
  1252.         my $status = $member->_writeCentralDirectoryFileHeader( $fh );
  1253.         return $status if $status != AZ_OK;
  1254.         $offset += $member->_centralDirectoryHeaderSize();
  1255.     }
  1256.     $self->{'writeEOCDOffset'} = $offset;
  1257.     return $self->_writeEndOfCentralDirectory( $fh );
  1258. }
  1259.  
  1260. #--------------------------------
  1261.  
  1262. =item read( $fileName )
  1263.  
  1264. Read zipfile headers from a zip file, appending new members.
  1265. Returns C<AZ_OK> or error code.
  1266.  
  1267.     my $zipFile = Archive::Zip->new();
  1268.     my $status = $zipFile->read( '/some/FileName.zip' );
  1269.  
  1270. =cut
  1271.  
  1272. sub read    # Archive::Zip::Archive
  1273. {
  1274.     my $self = shift;
  1275.     my $fileName = shift;
  1276.     return _error( 'No filename given' ) if ! $fileName;
  1277.     my ( $status, $fh ) = _newFileHandle( $fileName, 'r' );
  1278.     return _ioError( "opening $fileName for read" ) if !$status;
  1279.     _binmode( $fh );
  1280.  
  1281.     $status = $self->_findEndOfCentralDirectory( $fh );
  1282.     return $status if $status != AZ_OK;
  1283.  
  1284.     my $eocdPosition = $fh->tell();
  1285.  
  1286.     $status = $self->_readEndOfCentralDirectory( $fh );
  1287.     return $status if $status != AZ_OK;
  1288.  
  1289.     $fh->seek( $eocdPosition - $self->centralDirectorySize(),
  1290.         IO::Seekable::SEEK_SET )
  1291.             or return _ioError( "Can't seek $fileName" );
  1292.  
  1293.     for ( ;; )
  1294.     {
  1295.         my $newMember = 
  1296.             $self->ZIPMEMBERCLASS->_newFromZipFile( $fh, $fileName );
  1297.         my $signature;
  1298.         ( $status, $signature ) = $self->_readSignature( $fh, $fileName );
  1299.         return $status if $status != AZ_OK;
  1300.         last if $signature == END_OF_CENTRAL_DIRECTORY_SIGNATURE;
  1301.         $status = $newMember->_readCentralDirectoryFileHeader();
  1302.         return $status if $status != AZ_OK;
  1303.         $status = $newMember->endRead();
  1304.         return $status if $status != AZ_OK;
  1305.         $newMember->_becomeDirectoryIfNecessary();
  1306.         push( @{ $self->{'members'} }, $newMember );
  1307.     }
  1308.  
  1309.     $fh->close();
  1310.     return AZ_OK;
  1311. }
  1312.  
  1313. # Read EOCD, starting from position before signature.
  1314. # Return AZ_OK on success.
  1315. sub _readEndOfCentralDirectory    # Archive::Zip::Archive
  1316. {
  1317.     my $self = shift;
  1318.     my $fh = shift;
  1319.  
  1320.     # Skip past signature
  1321.     $fh->seek( SIGNATURE_LENGTH, IO::Seekable::SEEK_CUR )
  1322.         or return _ioError( "Can't seek past EOCD signature" );
  1323.  
  1324.     my $header = '';
  1325.     $fh->read( $header, END_OF_CENTRAL_DIRECTORY_LENGTH )
  1326.         or return _ioError( "reading end of central directory" );
  1327.  
  1328.     my $zipfileCommentLength;
  1329.     (
  1330.         $self->{'diskNumber'},
  1331.         $self->{'diskNumberWithStartOfCentralDirectory'},
  1332.         $self->{'numberOfCentralDirectoriesOnThisDisk'},
  1333.         $self->{'numberOfCentralDirectories'},
  1334.         $self->{'centralDirectorySize'},
  1335.         $self->{'centralDirectoryOffsetWRTStartingDiskNumber'},
  1336.         $zipfileCommentLength
  1337.      ) = unpack( END_OF_CENTRAL_DIRECTORY_FORMAT, $header );
  1338.  
  1339.     if ( $zipfileCommentLength )
  1340.     {
  1341.         my $zipfileComment = '';
  1342.         $fh->read( $zipfileComment, $zipfileCommentLength )
  1343.             or return _ioError( "reading zipfile comment" );
  1344.         $self->{'zipfileComment'} = $zipfileComment;
  1345.     }
  1346.  
  1347.     return AZ_OK;
  1348. }
  1349.  
  1350. # Seek in my file to the end, then read backwards until we find the
  1351. # signature of the central directory record. Leave the file positioned right
  1352. # before the signature. Returns AZ_OK if success.
  1353. sub _findEndOfCentralDirectory    # Archive::Zip::Archive
  1354. {
  1355.     my $self = shift;
  1356.     my $fh = shift;
  1357.     my $data = '';
  1358.     $fh->seek( 0, IO::Seekable::SEEK_END )
  1359.         or return _ioError( "seeking to end" );
  1360.  
  1361.     my $fileLength = $fh->tell();
  1362.     if ( $fileLength < END_OF_CENTRAL_DIRECTORY_LENGTH + 4 )
  1363.     {
  1364.         return _formatError( "file is too short" )
  1365.     }
  1366.  
  1367.     my $seekOffset = 0;
  1368.     my $pos = -1;
  1369.     for ( ;; )
  1370.     {
  1371.         $seekOffset += 512;
  1372.         $seekOffset = $fileLength if ( $seekOffset > $fileLength );
  1373.         $fh->seek( -$seekOffset, IO::Seekable::SEEK_END )
  1374.             or return _ioError( "seek failed" );
  1375.         $fh->read( $data, $seekOffset )
  1376.             or return _ioError( "read failed" );
  1377.         $pos = rindex( $data, END_OF_CENTRAL_DIRECTORY_SIGNATURE_STRING );
  1378.         last if ( $pos > 0
  1379.             or $seekOffset == $fileLength
  1380.             or $seekOffset >= $Archive::Zip::ChunkSize );
  1381.     }
  1382.  
  1383.     if ( $pos >= 0 )
  1384.     {
  1385.         $fh->seek( $pos - $seekOffset, IO::Seekable::SEEK_CUR )
  1386.             or return _ioError( "seeking to EOCD" );
  1387.         return AZ_OK;
  1388.     }
  1389.     else
  1390.     {
  1391.         return _formatError( "can't find EOCD signature" );
  1392.     }
  1393. }
  1394.  
  1395. =back
  1396.  
  1397. =head1 MEMBER OPERATIONS
  1398.  
  1399. =head2 Class Methods
  1400.  
  1401. Several constructors allow you to construct members without adding
  1402. them to a zip archive.
  1403.  
  1404. These work the same as the addFile(), addDirectory(), and addString()
  1405. zip instance methods described above, but they don't add the new members
  1406. to a zip.
  1407.  
  1408. =over 4
  1409.  
  1410. =cut
  1411.  
  1412. # ----------------------------------------------------------------------
  1413. # class Archive::Zip::Member
  1414. # A generic member of an archive ( abstract )
  1415. # ----------------------------------------------------------------------
  1416. package Archive::Zip::Member;
  1417. use vars qw( @ISA );
  1418. @ISA = qw ( Archive::Zip );
  1419.  
  1420. BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
  1421.     :UTILITY_METHODS ) }
  1422.  
  1423. use Time::Local ();
  1424. use Compress::Zlib qw( Z_OK Z_STREAM_END MAX_WBITS );
  1425. use File::Path;
  1426. use File::Basename;
  1427.  
  1428. use constant ZIPFILEMEMBERCLASS    => 'Archive::Zip::ZipFileMember';
  1429. use constant NEWFILEMEMBERCLASS    => 'Archive::Zip::NewFileMember';
  1430. use constant STRINGMEMBERCLASS    => 'Archive::Zip::StringMember';
  1431. use constant DIRECTORYMEMBERCLASS    => 'Archive::Zip::DirectoryMember';
  1432.  
  1433. # Unix perms for default creation of files/dirs.
  1434. use constant DEFAULT_DIRECTORY_PERMISSIONS => 040755;
  1435. use constant DEFAULT_FILE_PERMISSIONS => 0100666;
  1436. use constant DIRECTORY_ATTRIB => 040000;
  1437. use constant FILE_ATTRIB => 0100000;
  1438.  
  1439. # Returns self if successful, else undef
  1440. # Assumes that fh is positioned at beginning of central directory file header.
  1441. # Leaves fh positioned immediately after file header or EOCD signature.
  1442. sub _newFromZipFile # Archive::Zip::Member
  1443. {
  1444.     my $class = shift;
  1445.     my $self = $class->ZIPFILEMEMBERCLASS->_newFromZipFile( @_ );
  1446.     return $self;
  1447. }
  1448.  
  1449. #--------------------------------
  1450.  
  1451. =item Archive::Zip::Member->newFromString( $stringOrStringRef [, $fileName] )
  1452.  
  1453. Construct a new member from the given string. Returns undef on error.
  1454.  
  1455.     my $member = Archive::Zip::Member->newFromString( 'This is a test',
  1456.                                                      'xyz.txt' );
  1457.  
  1458. =cut
  1459.  
  1460. sub newFromString    # Archive::Zip::Member
  1461. {
  1462.     my $class = shift;
  1463.     my $self = $class->STRINGMEMBERCLASS->_newFromString( @_ );
  1464.     return $self;
  1465. }
  1466.  
  1467. #--------------------------------
  1468.  
  1469. =item newFromFile( $fileName )
  1470.  
  1471. Construct a new member from the given file. Returns undef on error.
  1472.  
  1473.     my $member = Archive::Zip::Member->newFromFile( 'xyz.txt' );
  1474.  
  1475. =cut
  1476.  
  1477. sub newFromFile    # Archive::Zip::Member
  1478. {
  1479.     my $class = shift;
  1480.     my $self = $class->NEWFILEMEMBERCLASS->_newFromFileNamed( @_ );
  1481.     return $self;
  1482. }
  1483.  
  1484. #--------------------------------
  1485.  
  1486. =item newDirectoryNamed( $directoryName )
  1487.  
  1488. Construct a new member from the given directory.
  1489. Returns undef on error.
  1490.  
  1491.     my $member = Archive::Zip::Member->newDirectoryNamed( 'CVS/' );
  1492.  
  1493. =cut
  1494.  
  1495. sub newDirectoryNamed # Archive::Zip::Member
  1496. {
  1497.     my $class = shift;
  1498.     my $self = $class->DIRECTORYMEMBERCLASS->_newNamed( @_ );
  1499.     return $self;
  1500. }
  1501.  
  1502. sub new    # Archive::Zip::Member
  1503. {
  1504.     my $class = shift;
  1505.     my $self = {
  1506.         'lastModFileDateTime' => 0,
  1507.         'fileAttributeFormat' => FA_UNIX,
  1508.         'versionMadeBy' => 20,
  1509.         'versionNeededToExtract' => 20,
  1510.         'bitFlag' => 0,
  1511.         'compressionMethod' => COMPRESSION_STORED,
  1512.         'desiredCompressionMethod' => COMPRESSION_STORED,
  1513.         'desiredCompressionLevel' => COMPRESSION_LEVEL_NONE,
  1514.         'internalFileAttributes' => 0,
  1515.         'externalFileAttributes' => 0,    # set later
  1516.         'fileName' => '',
  1517.         'cdExtraField' => '',
  1518.         'localExtraField' => '',
  1519.         'fileComment' => '',
  1520.         'crc32' => 0,
  1521.         'compressedSize' => 0,
  1522.         'uncompressedSize' => 0,
  1523.         @_
  1524.     };
  1525.     bless( $self, $class );
  1526.     $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
  1527.     return $self;
  1528. }
  1529.  
  1530. sub _becomeDirectoryIfNecessary    # Archive::Zip::Member
  1531. {
  1532.     my $self = shift;
  1533.     $self->_become( DIRECTORYMEMBERCLASS )
  1534.         if $self->isDirectory();
  1535.     return $self;
  1536. }
  1537.  
  1538. # Morph into given class (do whatever cleanup I need to do)
  1539. sub _become    # Archive::Zip::Member
  1540. {
  1541.     return bless( $_[0], $_[1] );
  1542. }
  1543.  
  1544. =back
  1545.  
  1546. =head2 Simple accessors
  1547.  
  1548. These methods get (and/or set) member attribute values.
  1549.  
  1550. =over 4
  1551.  
  1552. =cut
  1553.  
  1554. #--------------------------------
  1555.  
  1556. =item versionMadeBy()
  1557.  
  1558. Gets the field from my member header.
  1559.  
  1560. =cut
  1561.  
  1562. sub versionMadeBy    # Archive::Zip::Member
  1563. { shift->{'versionMadeBy'} }
  1564.  
  1565. #--------------------------------
  1566.  
  1567. =item fileAttributeFormat( [$format] )
  1568.  
  1569. Gets or sets the field from the member header.
  1570. These are C<FA_*> values.
  1571.  
  1572. =cut
  1573.  
  1574. sub fileAttributeFormat    # Archive::Zip::Member
  1575. {
  1576.     ( $#_ > 0 ) ? ( $_[0]->{'fileAttributeFormat'} = $_[1] )
  1577.         : $_[0]->{'fileAttributeFormat'}
  1578. }
  1579.  
  1580. #--------------------------------
  1581.  
  1582. =item versionNeededToExtract()
  1583.  
  1584. Gets the field from my member header.
  1585.  
  1586. =cut
  1587.  
  1588. sub versionNeededToExtract    # Archive::Zip::Member
  1589. { shift->{'versionNeededToExtract'} }
  1590.  
  1591. #--------------------------------
  1592.  
  1593. =item bitFlag()
  1594.  
  1595. Gets the general purpose bit field from my member header.
  1596. This is where the C<GPBF_*> bits live.
  1597.  
  1598. =cut
  1599.  
  1600. sub bitFlag    # Archive::Zip::Member
  1601. { shift->{'bitFlag'} }
  1602.  
  1603. #--------------------------------
  1604.  
  1605. =item compressionMethod()
  1606.  
  1607. Returns my compression method. This is the method that is
  1608. currently being used to compress my data.
  1609.  
  1610. This will be COMPRESSION_STORED for added string or file members,
  1611. or any of the C<COMPRESSION_*> values for members from a zip file.
  1612. However, this module can only handle members whose data is in
  1613. COMPRESSION_STORED or COMPRESSION_DEFLATED format.
  1614.  
  1615. =cut
  1616.  
  1617. sub compressionMethod    # Archive::Zip::Member
  1618. { shift->{'compressionMethod'} }
  1619.  
  1620. #--------------------------------
  1621.  
  1622. =item desiredCompressionMethod( [$method] )
  1623.  
  1624. Get or set my desiredCompressionMethod
  1625. This is the method that will be used to write.
  1626. Returns prior desiredCompressionMethod.
  1627.  
  1628. Only COMPRESSION_DEFLATED or COMPRESSION_STORED are valid arguments.
  1629.  
  1630. Changing to COMPRESSION_STORED will change my desiredCompressionLevel
  1631. to 0; changing to COMPRESSION_DEFLATED will change my
  1632. desiredCompressionLevel to COMPRESSION_LEVEL_DEFAULT.
  1633.  
  1634. =cut
  1635.  
  1636. sub desiredCompressionMethod    # Archive::Zip::Member
  1637. {
  1638.     my $self = shift;
  1639.     my $newDesiredCompressionMethod = shift;
  1640.     my $oldDesiredCompressionMethod = $self->{'desiredCompressionMethod'};
  1641.     if ( defined( $newDesiredCompressionMethod ))
  1642.     {
  1643.         $self->{'desiredCompressionMethod'} = $newDesiredCompressionMethod;
  1644.         if ( $newDesiredCompressionMethod == COMPRESSION_STORED )
  1645.         {
  1646.             $self->{'desiredCompressionLevel'} = 0;
  1647.         }
  1648.         elsif ( $oldDesiredCompressionMethod == COMPRESSION_STORED )
  1649.         {
  1650.             $self->{'desiredCompressionLevel'} = COMPRESSION_LEVEL_DEFAULT;
  1651.         }
  1652.     }
  1653.     return $oldDesiredCompressionMethod;
  1654. }
  1655.  
  1656. #--------------------------------
  1657.  
  1658. =item desiredCompressionLevel( [$method] )
  1659.  
  1660. Get or set my desiredCompressionLevel
  1661. This is the method that will be used to write.
  1662. Returns prior desiredCompressionLevel.
  1663.  
  1664. Valid arguments are 0 through 9, COMPRESSION_LEVEL_NONE,
  1665. COMPRESSION_LEVEL_DEFAULT, COMPRESSION_LEVEL_BEST_COMPRESSION, and
  1666. COMPRESSION_LEVEL_FASTEST.
  1667.  
  1668. 0 or COMPRESSION_LEVEL_NONE will change the desiredCompressionMethod
  1669. to COMPRESSION_STORED. All other arguments will change the
  1670. desiredCompressionMethod to COMPRESSION_DEFLATED.
  1671.  
  1672. =cut
  1673.  
  1674. sub desiredCompressionLevel    # Archive::Zip::Member
  1675. {
  1676.     my $self = shift;
  1677.     my $newDesiredCompressionLevel = shift;
  1678.     my $oldDesiredCompressionLevel = $self->{'desiredCompressionLevel'};
  1679.     if ( defined( $newDesiredCompressionLevel ))
  1680.     {
  1681.         $self->{'desiredCompressionLevel'} = $newDesiredCompressionLevel;
  1682.         $self->{'desiredCompressionMethod'} = ( $newDesiredCompressionLevel
  1683.             ? COMPRESSION_DEFLATED
  1684.             : COMPRESSION_STORED );
  1685.     }
  1686.     return $oldDesiredCompressionLevel;
  1687. }
  1688.  
  1689. #--------------------------------
  1690.  
  1691. =item fileName()
  1692.  
  1693. Get or set my internal filename.
  1694. Returns the (possibly new) filename.
  1695.  
  1696. Names will have backslashes converted to forward slashes,
  1697. and will have multiple consecutive slashes converted to single ones.
  1698.  
  1699. =cut
  1700.  
  1701. sub fileName    # Archive::Zip::Member
  1702. {
  1703.     my $self = shift;
  1704.     my $newName = shift;
  1705.     if ( $newName )
  1706.     {
  1707.         $newName =~ s{[\\/]+}{/}g;    # deal with dos/windoze problems
  1708.         $self->{'fileName'} = $newName;
  1709.     }
  1710.     return $self->{'fileName'}
  1711. }
  1712.  
  1713. #--------------------------------
  1714.  
  1715. =item lastModFileDateTime()
  1716.  
  1717. Return my last modification date/time stamp in MS-DOS format.
  1718.  
  1719. =cut
  1720.  
  1721. sub lastModFileDateTime    # Archive::Zip::Member
  1722. { shift->{'lastModFileDateTime'} }
  1723.  
  1724. #--------------------------------
  1725.  
  1726. =item lastModTime()
  1727.  
  1728. Return my last modification date/time stamp,
  1729. converted to unix localtime format.
  1730.  
  1731.     print "Mod Time: " . scalar( localtime( $member->lastModTime() ) );
  1732.  
  1733. =cut
  1734.  
  1735. sub lastModTime    # Archive::Zip::Member
  1736. {
  1737.     my $self = shift;
  1738.     return _dosToUnixTime( $self->lastModFileDateTime() );
  1739. }
  1740.  
  1741. #--------------------------------
  1742.  
  1743. =item setLastModFileDateTimeFromUnix()
  1744.  
  1745. Set my lastModFileDateTime from the given unix time.
  1746.  
  1747.     $member->setLastModFileDateTimeFromUnix( time() );
  1748.  
  1749. =cut
  1750.  
  1751. sub setLastModFileDateTimeFromUnix    # Archive::Zip::Member
  1752. {
  1753.     my $self = shift;
  1754.     my $time_t = shift;
  1755.     $self->{'lastModFileDateTime'} = _unixToDosTime( $time_t );
  1756. }
  1757.  
  1758. # Convert DOS date/time format to unix time_t format
  1759. # NOT AN OBJECT METHOD!
  1760. sub _dosToUnixTime    # Archive::Zip::Member
  1761. {
  1762.     my $dt = shift;
  1763.  
  1764.     my $year = ( ( $dt >> 25 ) & 0x7f ) + 80;
  1765.     my $mon  = ( ( $dt >> 21 ) & 0x0f ) - 1;
  1766.     my $mday = ( ( $dt >> 16 ) & 0x1f );
  1767.  
  1768.     my $hour = ( ( $dt >> 11 ) & 0x1f );
  1769.     my $min  = ( ( $dt >> 5 ) & 0x3f );
  1770.     my $sec  = ( ( $dt << 1 ) & 0x3e );
  1771.  
  1772.     my $time_t = Time::Local::timelocal( $sec, $min, $hour, $mday, $mon, $year );
  1773.     return $time_t;
  1774. }
  1775.  
  1776. #--------------------------------
  1777.  
  1778. =item internalFileAttributes()
  1779.  
  1780. Return the internal file attributes field from the zip header.
  1781. This is only set for members read from a zip file.
  1782.  
  1783. =cut
  1784.  
  1785. sub internalFileAttributes    # Archive::Zip::Member
  1786. { shift->{'internalFileAttributes'} }
  1787.  
  1788. #--------------------------------
  1789.  
  1790. =item externalFileAttributes()
  1791.  
  1792. Return member attributes as read from the ZIP file.
  1793. Note that these are NOT UNIX!
  1794.  
  1795. =cut
  1796.  
  1797. sub externalFileAttributes    # Archive::Zip::Member
  1798. { shift->{'externalFileAttributes'} }
  1799.  
  1800. # Convert UNIX permissions into proper value for zip file
  1801. # NOT A METHOD!
  1802. sub _mapPermissionsFromUnix    # Archive::Zip::Member
  1803. {
  1804.     my $perms = shift;
  1805.     return $perms << 16;
  1806.     # TODO: map MS-DOS perms too (RHSA?)
  1807. }
  1808.  
  1809. # Convert ZIP permissions into Unix ones
  1810. # NOT A METHOD!
  1811. sub _mapPermissionsToUnix    # Archive::Zip::Member
  1812. {
  1813.     my $perms = shift;
  1814.     return $perms >> 16;
  1815.     # TODO: Handle non-Unix perms
  1816. }
  1817.  
  1818. #--------------------------------
  1819.  
  1820. =item unixFileAttributes( [$newAttributes] )
  1821.  
  1822. Get or set the member's file attributes using UNIX file attributes.
  1823. Returns old attributes.
  1824.  
  1825.     my $oldAttribs = $member->unixFileAttributes( 0666 );
  1826.  
  1827. Note that the return value has more than just the file permissions,
  1828. so you will have to mask off the lowest bits for comparisions.
  1829.  
  1830. =cut
  1831.  
  1832. sub unixFileAttributes    # Archive::Zip::Member
  1833. {
  1834.     my $self = shift;
  1835.     my $oldPerms = _mapPermissionsToUnix( $self->{'externalFileAttributes'} );
  1836.     if ( @_ )
  1837.     {
  1838.         my $perms = shift;
  1839.         if ( $self->isDirectory() )
  1840.         {
  1841.             $perms &= ~FILE_ATTRIB;
  1842.             $perms |= DIRECTORY_ATTRIB;
  1843.         }
  1844.         else
  1845.         {
  1846.             $perms &= ~DIRECTORY_ATTRIB;
  1847.             $perms |= FILE_ATTRIB;
  1848.         }
  1849.         $self->{'externalFileAttributes'} = _mapPermissionsFromUnix( $perms);
  1850.     }
  1851.     return $oldPerms;
  1852. }
  1853.  
  1854. #--------------------------------
  1855.  
  1856. =item localExtraField( [$newField] )
  1857.  
  1858. Gets or sets the extra field that was read from the local header.
  1859. This is not set for a member from a zip file until after the
  1860. member has been written out.
  1861.  
  1862. The extra field must be in the proper format.
  1863.  
  1864. =cut
  1865.  
  1866. sub localExtraField    # Archive::Zip::Member
  1867. {
  1868.     ( $#_ > 0 ) ? ( $_[0]->{'localExtraField'} = $_[1] )
  1869.         : $_[0]->{'localExtraField'}
  1870. }
  1871.  
  1872. #--------------------------------
  1873.  
  1874. =item cdExtraField( [$newField] )
  1875.  
  1876. Gets or sets the extra field that was read from the central directory header.
  1877.  
  1878. The extra field must be in the proper format.
  1879.  
  1880. =cut
  1881.  
  1882. sub cdExtraField    # Archive::Zip::Member
  1883. {
  1884.     ( $#_ > 0 ) ? ( $_[0]->{'cdExtraField'} = $_[1] )
  1885.         : $_[0]->{'cdExtraField'}
  1886. }
  1887.  
  1888. #--------------------------------
  1889.  
  1890. =item extraFields()
  1891.  
  1892. Return both local and CD extra fields, concatenated.
  1893.  
  1894. =cut
  1895.  
  1896. sub extraFields    # Archive::Zip::Member
  1897. {
  1898.     my $self = shift;
  1899.     return $self->localExtraField() . $self->cdExtraField();
  1900. }
  1901.  
  1902. #--------------------------------
  1903.  
  1904. =item fileComment( [$newComment] )
  1905.  
  1906. Get or set the member's file comment.
  1907.  
  1908. =cut
  1909.  
  1910. sub fileComment    # Archive::Zip::Member
  1911. {
  1912.     ( $#_ > 0 ) ? ( $_[0]->{'fileComment'} = $_[1] )
  1913.         : $_[0]->{'fileComment'}
  1914. }
  1915.  
  1916. #--------------------------------
  1917.  
  1918. =item hasDataDescriptor()
  1919.  
  1920. Get or set the data descriptor flag.
  1921. If this is set, the local header will not necessarily
  1922. have the correct data sizes. Instead, a small structure
  1923. will be stored at the end of the member data with these
  1924. values.
  1925.  
  1926. This should be transparent in normal operation.
  1927.  
  1928. =cut
  1929.  
  1930. sub hasDataDescriptor    # Archive::Zip::Member
  1931. {
  1932.     my $self = shift;
  1933.     if ( @_ )
  1934.     {
  1935.         my $shouldHave = shift;
  1936.         if ( $shouldHave )
  1937.         {
  1938.             $self->{'bitFlag'} |= GPBF_HAS_DATA_DESCRIPTOR_MASK
  1939.         }
  1940.         else
  1941.         {
  1942.             $self->{'bitFlag'} &= ~GPBF_HAS_DATA_DESCRIPTOR_MASK
  1943.         }
  1944.     }
  1945.     return $self->{'bitFlag'} & GPBF_HAS_DATA_DESCRIPTOR_MASK;
  1946. }
  1947.  
  1948. #--------------------------------
  1949.  
  1950. =item crc32()
  1951.  
  1952. Return the CRC-32 value for this member.
  1953. This will not be set for members that were constructed from strings
  1954. or external files until after the member has been written.
  1955.  
  1956. =cut
  1957.  
  1958. sub crc32    # Archive::Zip::Member
  1959. { shift->{'crc32'} }
  1960.  
  1961. #--------------------------------
  1962.  
  1963. =item crc32String()
  1964.  
  1965. Return the CRC-32 value for this member as an 8 character printable
  1966. hex string.  This will not be set for members that were constructed
  1967. from strings or external files until after the member has been written.
  1968.  
  1969. =cut
  1970.  
  1971. sub crc32String    # Archive::Zip::Member
  1972. { sprintf( "%08x", shift->{'crc32'} ); }
  1973.  
  1974. #--------------------------------
  1975.  
  1976. =item compressedSize()
  1977.  
  1978. Return the compressed size for this member.
  1979. This will not be set for members that were constructed from strings
  1980. or external files until after the member has been written.
  1981.  
  1982. =cut
  1983.  
  1984. sub compressedSize    # Archive::Zip::Member
  1985. { shift->{'compressedSize'} }
  1986.  
  1987. #--------------------------------
  1988.  
  1989. =item uncompressedSize()
  1990.  
  1991. Return the uncompressed size for this member.
  1992.  
  1993. =cut
  1994.  
  1995. sub uncompressedSize    # Archive::Zip::Member
  1996. { shift->{'uncompressedSize'} }
  1997.  
  1998. #--------------------------------
  1999.  
  2000. =item isEncrypted()
  2001.  
  2002. Return true if this member is encrypted.
  2003. The Archive::Zip module does not currently create or extract
  2004. encrypted members.
  2005.  
  2006. =cut
  2007.  
  2008. sub isEncrypted    # Archive::Zip::Member
  2009. { shift->bitFlag() & GPBF_ENCRYPTED_MASK }
  2010.  
  2011.  
  2012. #--------------------------------
  2013.  
  2014. =item isTextFile( [$flag] )
  2015.  
  2016. Returns true if I am a text file.
  2017. Also can set the status if given an argument (then returns old state).
  2018. Note that this module does not currently do anything with this flag
  2019. upon extraction or storage.
  2020. That is, bytes are stored in native format whether or not they came
  2021. from a text file.
  2022.  
  2023. =cut
  2024.  
  2025. sub isTextFile    # Archive::Zip::Member
  2026. {
  2027.     my $self = shift;
  2028.     my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
  2029.     if ( @_ )
  2030.     {
  2031.         my $flag = shift;
  2032.         $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
  2033.         $self->{'internalFileAttributes'} |=
  2034.             ( $flag ? IFA_TEXT_FILE : IFA_BINARY_FILE );
  2035.     }
  2036.     return $bit == IFA_TEXT_FILE;
  2037. }
  2038.  
  2039. #--------------------------------
  2040.  
  2041. =item isBinaryFile()
  2042.  
  2043. Returns true if I am a binary file.
  2044. Also can set the status if given an argument (then returns old state).
  2045. Note that this module does not currently do anything with this flag
  2046. upon extraction or storage.
  2047. That is, bytes are stored in native format whether or not they came
  2048. from a text file.
  2049.  
  2050. =cut
  2051.  
  2052. sub isBinaryFile    # Archive::Zip::Member
  2053. {
  2054.     my $self = shift;
  2055.     my $bit = $self->internalFileAttributes() & IFA_TEXT_FILE_MASK;
  2056.     if ( @_ )
  2057.     {
  2058.         my $flag = shift;
  2059.         $self->{'internalFileAttributes'} &= ~IFA_TEXT_FILE_MASK;
  2060.         $self->{'internalFileAttributes'} |=
  2061.             ( $flag ? IFA_BINARY_FILE : IFA_TEXT_FILE );
  2062.     }
  2063.     return $bit == IFA_BINARY_FILE;
  2064. }
  2065.  
  2066. #--------------------------------
  2067.  
  2068. =item extractToFileNamed( $fileName )
  2069.  
  2070. Extract me to a file with the given name.
  2071. The file will be created with default modes.
  2072. Directories will be created as needed.
  2073.  
  2074. Returns AZ_OK on success.
  2075.  
  2076. =cut
  2077.  
  2078. sub extractToFileNamed    # Archive::Zip::Member
  2079. {
  2080.     my $self = shift;
  2081.     my $name = shift;
  2082.     return _error( "encryption unsupported" ) if $self->isEncrypted();
  2083.     mkpath( dirname( $name ) );    # croaks on error
  2084.     my ( $status, $fh ) = _newFileHandle( $name, 'w' );
  2085.     return _ioError( "Can't open file $name for write" ) if !$status;
  2086.     my $retval = $self->extractToFileHandle( $fh );
  2087.     $fh->close();
  2088.     return $retval;
  2089. }
  2090.  
  2091. #--------------------------------
  2092.  
  2093. =item isDirectory()
  2094.  
  2095. Returns true if I am a directory.
  2096.  
  2097. =cut
  2098.  
  2099. sub isDirectory    # Archive::Zip::Member
  2100. { return 0 }
  2101.  
  2102. # The following are used when copying data
  2103. sub _writeOffset    # Archive::Zip::Member
  2104. { shift->{'writeOffset'} }
  2105.  
  2106. sub _readOffset    # Archive::Zip::Member
  2107. { shift->{'readOffset'} }
  2108.  
  2109. sub _writeLocalHeaderRelativeOffset    # Archive::Zip::Member
  2110. { shift->{'writeLocalHeaderRelativeOffset'} }
  2111.  
  2112. sub _dataEnded    # Archive::Zip::Member
  2113. { shift->{'dataEnded'} }
  2114.  
  2115. sub _readDataRemaining    # Archive::Zip::Member
  2116. { shift->{'readDataRemaining'} }
  2117.  
  2118. sub _inflater    # Archive::Zip::Member
  2119. { shift->{'inflater'} }
  2120.  
  2121. sub _deflater    # Archive::Zip::Member
  2122. { shift->{'deflater'} }
  2123.  
  2124. # Return the total size of my local header
  2125. sub _localHeaderSize    # Archive::Zip::Member
  2126. {
  2127.     my $self = shift;
  2128.     return SIGNATURE_LENGTH
  2129.         + LOCAL_FILE_HEADER_LENGTH
  2130.         + length( $self->fileName() )
  2131.         + length( $self->localExtraField() )
  2132. }
  2133.  
  2134. # Return the total size of my CD header
  2135. sub _centralDirectoryHeaderSize    # Archive::Zip::Member
  2136. {
  2137.     my $self = shift;
  2138.     return SIGNATURE_LENGTH
  2139.         + CENTRAL_DIRECTORY_FILE_HEADER_LENGTH
  2140.         + length( $self->fileName() )
  2141.         + length( $self->cdExtraField() )
  2142.         + length( $self->fileComment() )
  2143. }
  2144.  
  2145. # convert a unix time to DOS date/time
  2146. # NOT AN OBJECT METHOD!
  2147. sub _unixToDosTime    # Archive::Zip::Member
  2148. {
  2149.     my $time_t = shift;
  2150.     my ( $sec,$min,$hour,$mday,$mon,$year ) = localtime( $time_t );
  2151.     my $dt = 0;
  2152.     $dt += ( $sec >> 1 );
  2153.     $dt += ( $min << 5 );
  2154.     $dt += ( $hour << 11 );
  2155.     $dt += ( $mday << 16 );
  2156.     $dt += ( ( $mon + 1 ) << 21 );
  2157.     $dt += ( ( $year - 80 ) << 25 );
  2158.     return $dt;
  2159. }
  2160.  
  2161. # Write my local header to a file handle.
  2162. # Stores the offset to the start of the header in my
  2163. # writeLocalHeaderRelativeOffset member.
  2164. # Returns AZ_OK on success.
  2165. sub _writeLocalFileHeader    # Archive::Zip::Member
  2166. {
  2167.     my $self = shift;
  2168.     my $fh = shift;
  2169.  
  2170.     my $signatureData = pack( SIGNATURE_FORMAT, LOCAL_FILE_HEADER_SIGNATURE );
  2171.     $fh->write( $signatureData, SIGNATURE_LENGTH )
  2172.         or return _ioError( "writing local header signature" );
  2173.  
  2174.     my $header = pack( LOCAL_FILE_HEADER_FORMAT,
  2175.         $self->versionNeededToExtract(),
  2176.         $self->bitFlag(),
  2177.         $self->desiredCompressionMethod(),
  2178.         $self->lastModFileDateTime(),
  2179.         $self->crc32(),
  2180.         $self->compressedSize(),        # may need to be re-written later
  2181.         $self->uncompressedSize(),
  2182.         length( $self->fileName() ),
  2183.         length( $self->localExtraField() )
  2184.          );
  2185.  
  2186.     $fh->write( $header, LOCAL_FILE_HEADER_LENGTH )
  2187.         or return _ioError( "writing local header" );
  2188.     if ( length( $self->fileName() ))
  2189.     {
  2190.         $fh->write( $self->fileName(), length( $self->fileName() ))
  2191.             or return _ioError( "writing local header filename" );
  2192.     }
  2193.     if ( length( $self->localExtraField() ))
  2194.     {
  2195.         $fh->write( $self->localExtraField(), length( $self->localExtraField() ))
  2196.             or return _ioError( "writing local header signature" );
  2197.     }
  2198.  
  2199.     return AZ_OK;
  2200. }
  2201.  
  2202. sub _writeCentralDirectoryFileHeader    # Archive::Zip::Member
  2203. {
  2204.     my $self = shift;
  2205.     my $fh = shift;
  2206.  
  2207.     my $sigData = pack( SIGNATURE_FORMAT,
  2208.         CENTRAL_DIRECTORY_FILE_HEADER_SIGNATURE );
  2209.     $fh->write( $sigData, SIGNATURE_LENGTH )
  2210.         or return _ioError( "writing central directory header signature" );
  2211.  
  2212.     my $fileNameLength = length( $self->fileName() );
  2213.     my $extraFieldLength = length( $self->cdExtraField() );
  2214.     my $fileCommentLength = length( $self->fileComment() );
  2215.  
  2216.     my $header = pack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT,
  2217.         $self->versionMadeBy(),
  2218.         $self->fileAttributeFormat(),
  2219.         $self->versionNeededToExtract(),
  2220.         $self->bitFlag(),
  2221.         $self->desiredCompressionMethod(),
  2222.         $self->lastModFileDateTime(),
  2223.         $self->crc32(),            # these three fields should have been updated
  2224.         $self->_writeOffset(),    # by writing the data stream out
  2225.         $self->uncompressedSize(),    #
  2226.         $fileNameLength,
  2227.         $extraFieldLength,
  2228.         $fileCommentLength,
  2229.         0,                        # {'diskNumberStart'},
  2230.         $self->internalFileAttributes(),
  2231.         $self->externalFileAttributes(),
  2232.         $self->_writeLocalHeaderRelativeOffset()
  2233.      );
  2234.  
  2235.     $fh->write( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH )
  2236.         or return _ioError( "writing central directory header" );
  2237.     if ( $fileNameLength )
  2238.     {
  2239.         $fh->write( $self->fileName(), $fileNameLength )
  2240.             or return _ioError( "writing central directory header signature" );
  2241.     }
  2242.     if ( $extraFieldLength )
  2243.     {
  2244.         $fh->write( $self->cdExtraField(), $extraFieldLength )
  2245.             or return _ioError( "writing central directory extra field" );
  2246.     }
  2247.     if ( $fileCommentLength )
  2248.     {
  2249.         $fh->write( $self->fileComment(), $fileCommentLength )
  2250.             or return _ioError( "writing central directory file comment" );
  2251.     }
  2252.  
  2253.     return AZ_OK;
  2254. }
  2255.  
  2256. # This writes a data descriptor to the given file handle.
  2257. # Assumes that crc32, writeOffset, and uncompressedSize are
  2258. # set correctly (they should be after a write).
  2259. # Further, the local file header should have the
  2260. # GPBF_HAS_DATA_DESCRIPTOR_MASK bit set.
  2261. sub _writeDataDescriptor    # Archive::Zip::Member
  2262. {
  2263.     my $self = shift;
  2264.     my $fh = shift;
  2265.     my $header = pack( DATA_DESCRIPTOR_FORMAT,
  2266.         $self->crc32(),
  2267.         $self->_writeOffset(),
  2268.         $self->uncompressedSize()
  2269.      );
  2270.  
  2271.     $fh->write( $header, DATA_DESCRIPTOR_LENGTH )
  2272.         or return _ioError( "writing data descriptor" );
  2273.     return AZ_OK;
  2274. }
  2275.  
  2276. # Re-writes the local file header with new crc32 and compressedSize fields.
  2277. # To be called after writing the data stream.
  2278. # Assumes that filename and extraField sizes didn't change since last written.
  2279. sub _refreshLocalFileHeader    # Archive::Zip::Member
  2280. {
  2281.     my $self = shift;
  2282.     my $fh = shift;
  2283.  
  2284.     my $here = $fh->tell();
  2285.     $fh->seek( $self->_writeLocalHeaderRelativeOffset() + SIGNATURE_LENGTH,
  2286.         IO::Seekable::SEEK_SET )
  2287.             or return _ioError( "seeking to rewrite local header" );
  2288.  
  2289.     my $header = pack( LOCAL_FILE_HEADER_FORMAT,
  2290.         $self->versionNeededToExtract(),
  2291.         $self->bitFlag(),
  2292.         $self->desiredCompressionMethod(),
  2293.         $self->lastModFileDateTime(),
  2294.         $self->crc32(),
  2295.         $self->_writeOffset(),
  2296.         $self->uncompressedSize(),
  2297.         length( $self->fileName() ),
  2298.         length( $self->localExtraField() )
  2299.          );
  2300.  
  2301.     $fh->write( $header, LOCAL_FILE_HEADER_LENGTH )
  2302.         or return _ioError( "re-writing local header" );
  2303.     $fh->seek( $here, IO::Seekable::SEEK_SET )
  2304.             or return _ioError( "seeking after rewrite of local header" );
  2305.  
  2306.     return AZ_OK;
  2307. }
  2308.  
  2309. =back
  2310.  
  2311. =head2 Low-level member data reading
  2312.  
  2313. It is possible to use lower-level routines to access member
  2314. data streams, rather than the extract* methods and contents().
  2315.  
  2316. For instance, here is how to print the uncompressed contents
  2317. of a member in chunks using these methods:
  2318.  
  2319.     my ( $member, $status, $bufferRef );
  2320.     $member = $zip->memberNamed( 'xyz.txt' );
  2321.     $member->desiredCompressionMethod( COMPRESSION_STORED );
  2322.     $status = $member->rewindData();
  2323.     die "error $status" if $status != AZ_OK;
  2324.     while ( ! $member->readIsDone() )
  2325.     {
  2326.         ( $bufferRef, $status ) = $member->readChunk();
  2327.         die "error $status" if $status != AZ_OK;
  2328.         # do something with $bufferRef:
  2329.         print $$bufferRef;
  2330.     }
  2331.     $member->endRead();
  2332.  
  2333. =over 4
  2334.  
  2335. =cut
  2336.  
  2337. #--------------------------------
  2338.  
  2339. =item readChunk( [$chunkSize] )
  2340.  
  2341. This reads the next chunk of given size from the member's data stream and
  2342. compresses or uncompresses it as necessary, returning a reference to the bytes
  2343. read and a status.
  2344. If size argument is not given, defaults to global set by
  2345. Archive::Zip::setChunkSize.
  2346. Status is AZ_OK on success. Returns C<( \$bytes, $status)>.
  2347.  
  2348.     my ( $outRef, $status ) = $self->readChunk();
  2349.     print $$outRef if $status != AZ_OK;
  2350.  
  2351. =cut
  2352.  
  2353. sub readChunk    # Archive::Zip::Member
  2354. {
  2355.     my ( $self, $chunkSize ) = @_;
  2356.  
  2357.     if ( $self->readIsDone() )
  2358.     {
  2359.         $self->endRead();
  2360.         my $dummy = '';
  2361.         return ( \$dummy, AZ_STREAM_END );
  2362.     }
  2363.  
  2364.     $chunkSize = $Archive::Zip::ChunkSize if not defined( $chunkSize );
  2365.     $chunkSize = $self->_readDataRemaining()
  2366.         if $chunkSize > $self->_readDataRemaining();
  2367.  
  2368.     my $buffer = '';
  2369.     my $outputRef;
  2370.     my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
  2371.     return ( \$buffer, $status) if $status != AZ_OK;
  2372.  
  2373.     $self->{'readDataRemaining'} -= $bytesRead;
  2374.     $self->{'readOffset'} += $bytesRead;
  2375.  
  2376.     if ( $self->compressionMethod() == COMPRESSION_STORED )
  2377.     {
  2378.         $self->{'crc32'} = $self->computeCRC32( $buffer, $self->{'crc32'} );
  2379.     }
  2380.  
  2381.     ( $outputRef, $status) = &{$self->{'chunkHandler'}}( $self, \$buffer );
  2382.     $self->{'writeOffset'} += length( $$outputRef );
  2383.  
  2384.     $self->endRead()
  2385.         if $self->readIsDone();
  2386.  
  2387.     return ( $outputRef, $status);
  2388. }
  2389.  
  2390. # Read the next raw chunk of my data. Subclasses MUST implement.
  2391. #    my ( $bytesRead, $status) = $self->_readRawChunk( \$buffer, $chunkSize );
  2392. sub _readRawChunk    # Archive::Zip::Member
  2393. {
  2394.     my $self = shift;
  2395.     return $self->_subclassResponsibility();
  2396. }
  2397.  
  2398. # A place holder to catch rewindData errors if someone ignores
  2399. # the error code.
  2400. sub _noChunk    # Archive::Zip::Member
  2401. {
  2402.     my $self = shift;
  2403.     return ( \undef, _error( "trying to copy chunk when init failed" ));
  2404. }
  2405.  
  2406. # Basically a no-op so that I can have a consistent interface.
  2407. # ( $outputRef, $status) = $self->_copyChunk( \$buffer );
  2408. sub _copyChunk    # Archive::Zip::Member
  2409. {
  2410.     my ( $self, $dataRef ) = @_;
  2411.     return ( $dataRef, AZ_OK );
  2412. }
  2413.  
  2414.  
  2415. # ( $outputRef, $status) = $self->_deflateChunk( \$buffer );
  2416. sub _deflateChunk    # Archive::Zip::Member
  2417. {
  2418.     my ( $self, $buffer ) = @_;
  2419.     my ( $out, $status ) = $self->_deflater()->deflate( $buffer );
  2420.  
  2421.     if ( $self->_readDataRemaining() == 0 )
  2422.     {
  2423.         my $extraOutput;
  2424.         ( $extraOutput, $status ) = $self->_deflater()->flush();
  2425.         $out .= $extraOutput;
  2426.         $self->endRead();
  2427.         return ( \$out, AZ_STREAM_END );
  2428.     }
  2429.     elsif ( $status == Z_OK )
  2430.     {
  2431.         return ( \$out, AZ_OK );
  2432.     }
  2433.     else
  2434.     {
  2435.         $self->endRead();
  2436.         my $retval = _error( 'deflate error', $status);
  2437.         my $dummy = '';
  2438.         return ( \$dummy, $retval );
  2439.     }
  2440. }
  2441.  
  2442. # ( $outputRef, $status) = $self->_inflateChunk( \$buffer );
  2443. sub _inflateChunk    # Archive::Zip::Member
  2444. {
  2445.     my ( $self, $buffer ) = @_;
  2446.     my ( $out, $status ) = $self->_inflater()->inflate( $buffer );
  2447.     my $retval;
  2448.     $self->endRead() if ( $status != Z_OK );
  2449.     if ( $status == Z_OK || $status == Z_STREAM_END )
  2450.     {
  2451.         $retval = ( $status == Z_STREAM_END )
  2452.             ? AZ_STREAM_END : AZ_OK;
  2453.         return ( \$out, $retval );
  2454.     }
  2455.     else
  2456.     {
  2457.         $retval = _error( 'inflate error', $status);
  2458.         my $dummy = '';
  2459.         return ( \$dummy, $retval );
  2460.     }
  2461. }
  2462.  
  2463. #--------------------------------
  2464.  
  2465. =item rewindData()
  2466.  
  2467. Rewind data and set up for reading data streams or writing zip files.
  2468. Can take options for C<inflateInit()> or C<deflateInit()>,
  2469. but this isn't likely to be necessary.
  2470. Subclass overrides should call this method.
  2471. Returns C<AZ_OK> on success.
  2472.  
  2473. =cut
  2474.  
  2475. sub rewindData    # Archive::Zip::Member
  2476. {
  2477.     my $self = shift;
  2478.     my $status;
  2479.  
  2480.     # set to trap init errors
  2481.     $self->{'chunkHandler'} = $self->can( '_noChunk' );
  2482.  
  2483.     # Work around WinZip bug with 0-length DEFLATED files
  2484.     $self->desiredCompressionMethod( COMPRESSION_STORED )
  2485.         if $self->uncompressedSize() == 0;
  2486.  
  2487.     # assume that we're going to read the whole file, and compute the CRC anew.
  2488.     $self->{'crc32'} = 0 if ( $self->compressionMethod() == COMPRESSION_STORED );
  2489.  
  2490.     # These are the only combinations of methods we deal with right now.
  2491.     if ( $self->compressionMethod() == COMPRESSION_STORED
  2492.             and $self->desiredCompressionMethod() == COMPRESSION_DEFLATED )
  2493.     {
  2494.         ( $self->{'deflater'}, $status ) = Compress::Zlib::deflateInit(
  2495.             '-Level' => $self->desiredCompressionLevel(),
  2496.             '-WindowBits' => - MAX_WBITS(), # necessary magic
  2497.             @_ );    # pass additional options
  2498.         return _error( 'deflateInit error:', $status ) if $status != Z_OK;
  2499.         $self->{'chunkHandler'} = $self->can( '_deflateChunk' );
  2500.     }
  2501.     elsif ( $self->compressionMethod() == COMPRESSION_DEFLATED
  2502.             and $self->desiredCompressionMethod() == COMPRESSION_STORED )
  2503.     {
  2504.         ( $self->{'inflater'}, $status ) = Compress::Zlib::inflateInit(
  2505.             '-WindowBits' => - MAX_WBITS(), # necessary magic
  2506.             @_ );    # pass additional options
  2507.         return _error( 'inflateInit error:', $status ) if $status != Z_OK;
  2508.         $self->{'chunkHandler'} = $self->can( '_inflateChunk' );
  2509.     }
  2510.     elsif ( $self->compressionMethod() == $self->desiredCompressionMethod() )
  2511.     {
  2512.         $self->{'chunkHandler'} = $self->can( '_copyChunk' );
  2513.     }
  2514.     else
  2515.     {
  2516.         return _error(
  2517.             sprintf( "Unsupported compression combination: read %d, write %d",
  2518.                 $self->compressionMethod(),
  2519.                 $self->desiredCompressionMethod() )
  2520.          );
  2521.     }
  2522.  
  2523.     $self->{'dataEnded'} = 0;
  2524.     $self->{'readDataRemaining'} = $self->compressedSize();
  2525.     $self->{'readOffset'} = 0;
  2526.  
  2527.     return AZ_OK;
  2528. }
  2529.  
  2530. #--------------------------------
  2531.  
  2532. =item endRead()
  2533.  
  2534. Reset the read variables and free the inflater or deflater.
  2535. Must be called to close files, etc.
  2536.  
  2537. Returns AZ_OK on success.
  2538.  
  2539. =cut
  2540.  
  2541. sub endRead    # Archive::Zip::Member
  2542. {
  2543.     my $self = shift;
  2544.     delete $self->{'inflater'};
  2545.     delete $self->{'deflater'};
  2546.     $self->{'dataEnded'} = 1;
  2547.     $self->{'readDataRemaining'} = 0;
  2548.     return AZ_OK;
  2549. }
  2550.  
  2551. #--------------------------------
  2552.  
  2553. =item readIsDone()
  2554.  
  2555. Return true if the read has run out of data or errored out.
  2556.  
  2557. =cut
  2558.  
  2559. sub readIsDone    # Archive::Zip::Member
  2560. {
  2561.     my $self = shift;
  2562.     return ( $self->_dataEnded() or ! $self->_readDataRemaining() );
  2563. }
  2564.  
  2565. #--------------------------------
  2566.  
  2567. =item contents()
  2568.  
  2569. Return the entire uncompressed member data or undef in scalar context.
  2570. When called in array context, returns C<( $string, $status )>; status
  2571. will be AZ_OK on success:
  2572.  
  2573.     my $string = $member->contents();
  2574.     # or
  2575.     my ( $string, $status ) = $member->contents();
  2576.     die "error $status" if $status != AZ_OK;
  2577.  
  2578. Can also be used to set the contents of a member (this may change
  2579. the class of the member):
  2580.  
  2581.     $member->contents( "this is my new contents" );
  2582.  
  2583. =cut
  2584.  
  2585. sub contents    # Archive::Zip::Member
  2586. {
  2587.     my $self = shift;
  2588.     my $newContents = shift;
  2589.     if ( defined( $newContents ) )
  2590.     {
  2591.         $self->_become( STRINGMEMBERCLASS );
  2592.         return $self->contents( $newContents );
  2593.     }
  2594.     else
  2595.     {
  2596.         my $oldCompression = 
  2597.             $self->desiredCompressionMethod( COMPRESSION_STORED );
  2598.         my $status = $self->rewindData( @_ );
  2599.         if ( $status != AZ_OK )
  2600.         {
  2601.             $self->endRead();
  2602.             return $status;
  2603.         }
  2604.         my $retval = '';
  2605.         while ( $status == AZ_OK )
  2606.         {
  2607.             my $ref;
  2608.             ( $ref, $status ) = $self->readChunk( $self->_readDataRemaining() );
  2609.             # did we get it in one chunk?
  2610.             if ( length( $$ref ) == $self->uncompressedSize() )
  2611.             { $retval = $$ref }
  2612.             else
  2613.             { $retval .= $$ref }
  2614.         }
  2615.         $self->desiredCompressionMethod( $oldCompression );
  2616.         $self->endRead();
  2617.         $status = AZ_OK if $status == AZ_STREAM_END;
  2618.         $retval = undef if $status != AZ_OK;
  2619.         return wantarray ? ( $retval, $status ) : $retval;
  2620.     }
  2621. }
  2622.  
  2623. #--------------------------------
  2624.  
  2625. =item extractToFileHandle( $fh )
  2626.  
  2627. Extract (and uncompress, if necessary) my contents to the given file handle.
  2628. Return AZ_OK on success.
  2629.  
  2630. =cut
  2631.  
  2632. sub extractToFileHandle    # Archive::Zip::Member
  2633. {
  2634.     my $self = shift;
  2635.     return _error( "encryption unsupported" ) if $self->isEncrypted();
  2636.     my $fh = shift;
  2637.     _binmode( $fh );
  2638.     my $oldCompression = $self->desiredCompressionMethod( COMPRESSION_STORED );
  2639.     my $status = $self->rewindData( @_ );
  2640.     $status = $self->_writeData( $fh ) if $status == AZ_OK;
  2641.     $self->desiredCompressionMethod( $oldCompression );
  2642.     $self->endRead();
  2643.     return $status;
  2644. }
  2645.  
  2646. # write local header and data stream to file handle
  2647. sub _writeToFileHandle    # Archive::Zip::Member
  2648. {
  2649.     my $self = shift;
  2650.     my $fh = shift;
  2651.     my $fhIsSeekable = shift;
  2652.  
  2653.     # Determine if I need to write a data descriptor
  2654.     # I need to do this if I can't refresh the header
  2655.     # and I don't know compressed size or crc32 fields.
  2656.     my $headerFieldsUnknown = ( ( $self->uncompressedSize() > 0 )
  2657.         and ( $self->compressionMethod() == COMPRESSION_STORED
  2658.             or $self->desiredCompressionMethod() == COMPRESSION_DEFLATED ) );
  2659.  
  2660.     my $shouldWriteDataDescriptor =
  2661.         ( $headerFieldsUnknown and not $fhIsSeekable );
  2662.  
  2663.     $self->hasDataDescriptor( 1 )
  2664.         if ( $shouldWriteDataDescriptor );
  2665.  
  2666.     $self->{'writeOffset'} = 0;
  2667.  
  2668.     my $status = $self->rewindData();
  2669.     ( $status = $self->_writeLocalFileHeader( $fh ) )
  2670.         if $status == AZ_OK;
  2671.     ( $status = $self->_writeData( $fh ) )
  2672.         if $status == AZ_OK;
  2673.     if ( $status == AZ_OK )
  2674.     {
  2675.         if ( $self->hasDataDescriptor() )
  2676.         {
  2677.             $status = $self->_writeDataDescriptor( $fh );
  2678.         }
  2679.         elsif ( $headerFieldsUnknown )
  2680.         {
  2681.             $status = $self->_refreshLocalFileHeader( $fh );
  2682.         }
  2683.     }
  2684.  
  2685.     return $status;
  2686. }
  2687.  
  2688. # Copy my (possibly compressed) data to given file handle.
  2689. # Returns C<AZ_OK> on success
  2690. sub _writeData    # Archive::Zip::Member
  2691. {
  2692.     my $self = shift;
  2693.     my $writeFh = shift;
  2694.  
  2695.     return AZ_OK if ( $self->uncompressedSize() == 0 );
  2696.     my $status;
  2697.     my $chunkSize = $Archive::Zip::ChunkSize;
  2698.     while ( $self->_readDataRemaining() > 0 )
  2699.     {
  2700.         my $outRef;
  2701.         ( $outRef, $status ) = $self->readChunk( $chunkSize );
  2702.         return $status if ( $status != AZ_OK and $status != AZ_STREAM_END );
  2703.  
  2704.         $writeFh->write( $$outRef, length( $$outRef ) )
  2705.             or return _ioError( "write error during copy" );
  2706.  
  2707.         last if $status == AZ_STREAM_END;
  2708.     }
  2709.     return AZ_OK;
  2710. }
  2711.  
  2712.  
  2713. # Return true if I depend on the named file
  2714. sub _usesFileNamed
  2715. {
  2716.     return 0;
  2717. }
  2718.  
  2719. # ----------------------------------------------------------------------
  2720. # class Archive::Zip::DirectoryMember
  2721. # ----------------------------------------------------------------------
  2722.  
  2723. package Archive::Zip::DirectoryMember;
  2724. use File::Path;
  2725.  
  2726. use vars qw( @ISA );
  2727. @ISA = qw ( Archive::Zip::Member );
  2728. BEGIN { use Archive::Zip qw( :ERROR_CODES :UTILITY_METHODS ) }
  2729.  
  2730. sub _newNamed    # Archive::Zip::DirectoryMember
  2731. {
  2732.     my $class = shift;
  2733.     my $name = shift;
  2734.     my $self = $class->new( @_ );
  2735.     $self->fileName( $name );
  2736.     if ( -d $name )
  2737.     {
  2738.         my @stat = stat( _ );
  2739.         $self->unixFileAttributes( $stat[2] );
  2740.         $self->setLastModFileDateTimeFromUnix( $stat[9] );
  2741.     }
  2742.     else
  2743.     {
  2744.         $self->unixFileAttributes( $self->DEFAULT_DIRECTORY_PERMISSIONS );
  2745.         $self->setLastModFileDateTimeFromUnix( time() );
  2746.     }
  2747.     return $self;
  2748. }
  2749.  
  2750. sub isDirectory    # Archive::Zip::DirectoryMember
  2751. { return 1; }
  2752.  
  2753. sub extractToFileNamed    # Archive::Zip::DirectoryMember
  2754. {
  2755.     my $self = shift;
  2756.     my $name = shift;
  2757.     my $attribs = $self->unixFileAttributes() & 07777;
  2758.     mkpath( $name, 0, $attribs );    # croaks on error
  2759.     return AZ_OK;
  2760. }
  2761.  
  2762. sub fileName    # Archive::Zip::DirectoryMember
  2763. {
  2764.     my $self = shift;
  2765.     my $newName = shift;
  2766.     $newName =~ s{/?$}{/} if defined( $newName );
  2767.     return $self->SUPER::fileName( $newName );
  2768. }
  2769.  
  2770. =back
  2771.  
  2772. =head1 Archive::Zip::FileMember methods
  2773.  
  2774. The Archive::Zip::FileMember class extends Archive::Zip::Member.
  2775. It is the base class for both ZipFileMember and NewFileMember classes.
  2776. This class adds an C<externalFileName> and an C<fh> member to keep
  2777. track of the external file.
  2778.  
  2779. =over 4
  2780.  
  2781. =cut
  2782.  
  2783. # ----------------------------------------------------------------------
  2784. # class Archive::Zip::FileMember
  2785. # Base class for classes that have file handles
  2786. # to external files
  2787. # ----------------------------------------------------------------------
  2788.  
  2789. package Archive::Zip::FileMember;
  2790. use vars qw( @ISA );
  2791. @ISA = qw ( Archive::Zip::Member );
  2792. BEGIN { use Archive::Zip qw( :UTILITY_METHODS ) }
  2793.  
  2794. #--------------------------------
  2795.  
  2796. =item externalFileName()
  2797.  
  2798. Return my external filename.
  2799.  
  2800. =cut
  2801.  
  2802. sub externalFileName    # Archive::Zip::FileMember
  2803. { shift->{'externalFileName'} }
  2804.  
  2805. #--------------------------------
  2806.  
  2807. # Return true if I depend on the named file
  2808. sub _usesFileNamed
  2809. {
  2810.     my $self = shift;
  2811.     my $fileName = shift;
  2812.     return $self->externalFileName eq $fileName;
  2813. }
  2814.  
  2815. =item fh()
  2816.  
  2817. Return my read file handle.
  2818. Automatically opens file if necessary.
  2819.  
  2820. =cut
  2821.  
  2822. sub fh    # Archive::Zip::FileMember
  2823. {
  2824.     my $self = shift;
  2825.     $self->_openFile() if ! $self->{'fh'};
  2826.     return $self->{'fh'};
  2827. }
  2828.  
  2829. # opens my file handle from my file name
  2830. sub _openFile    # Archive::Zip::FileMember
  2831. {
  2832.     my $self = shift;
  2833.     my ( $status, $fh ) = _newFileHandle( $self->externalFileName(), 'r' );
  2834.     if ( !$status )
  2835.     {
  2836.         _ioError( "Can't open", $self->externalFileName() );
  2837.         return undef;
  2838.     }
  2839.     $self->{'fh'} = $fh;
  2840.     _binmode( $fh );
  2841.     return $fh;
  2842. }
  2843.  
  2844. # Closes my file handle
  2845. sub _closeFile    # Archive::Zip::FileMember
  2846. {
  2847.     my $self = shift;
  2848.     $self->{'fh'} = undef;
  2849. }
  2850.  
  2851. # Make sure I close my file handle
  2852. sub endRead    # Archive::Zip::FileMember
  2853. {
  2854.     my $self = shift;
  2855.     $self->_closeFile();
  2856.     return $self->SUPER::endRead( @_ );
  2857. }
  2858.  
  2859. sub _become    # Archive::Zip::FileMember
  2860. {
  2861.     my $self = shift;
  2862.     my $newClass = shift;
  2863.     return $self if ref( $self ) eq $newClass;
  2864.     delete( $self->{'externalFileName'} );
  2865.     delete( $self->{'fh'} );
  2866.     return $self->SUPER::_become( $newClass );
  2867. }
  2868.  
  2869. # ----------------------------------------------------------------------
  2870. # class Archive::Zip::NewFileMember
  2871. # Used when adding a pre-existing file to an archive
  2872. # ----------------------------------------------------------------------
  2873.  
  2874. package Archive::Zip::NewFileMember;
  2875. use vars qw( @ISA );
  2876. @ISA = qw ( Archive::Zip::FileMember );
  2877.  
  2878. BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :UTILITY_METHODS ) }
  2879.  
  2880. # Given a file name, set up for eventual writing.
  2881. sub _newFromFileNamed    # Archive::Zip::NewFileMember
  2882. {
  2883.     my $class = shift;
  2884.     my $fileName = shift;
  2885.     return undef if ! ( -r $fileName && ( -f _ || -l _ ) );
  2886.     my $self = $class->new( @_ );
  2887.     $self->fileName( $fileName );
  2888.     $self->{'externalFileName'} = $fileName;
  2889.     $self->{'compressionMethod'} = COMPRESSION_STORED;
  2890.     my @stat = stat( _ );
  2891.     $self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7];
  2892.     $self->desiredCompressionMethod( ( $self->compressedSize() > 0 )
  2893.         ? COMPRESSION_DEFLATED
  2894.         : COMPRESSION_STORED );
  2895.     $self->unixFileAttributes( $stat[2] );
  2896.     $self->setLastModFileDateTimeFromUnix( $stat[9] );
  2897.     $self->isTextFile( -T _ );
  2898.     return $self;
  2899. }
  2900.  
  2901. sub rewindData    # Archive::Zip::NewFileMember
  2902. {
  2903.     my $self = shift;
  2904.  
  2905.     my $status = $self->SUPER::rewindData( @_ );
  2906.     return $status if $status != AZ_OK;
  2907.  
  2908.     return AZ_IO_ERROR if ! $self->fh();
  2909.     $self->fh()->clearerr();
  2910.     $self->fh()->seek( 0, IO::Seekable::SEEK_SET )
  2911.         or return _ioError( "rewinding", $self->externalFileName() );
  2912.     return AZ_OK;
  2913. }
  2914.  
  2915. # Return bytes read. Note that first parameter is a ref to a buffer.
  2916. # my $data;
  2917. # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
  2918. sub _readRawChunk    # Archive::Zip::NewFileMember
  2919. {
  2920.     my ( $self, $dataRef, $chunkSize ) = @_;
  2921.     return ( 0, AZ_OK ) if ( ! $chunkSize );
  2922.     my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
  2923.         or return ( 0, _ioError( "reading data" ) );
  2924.     return ( $bytesRead, AZ_OK );
  2925. }
  2926.  
  2927. # If I already exist, extraction is a no-op.
  2928. sub extractToFileNamed    # Archive::Zip::NewFileMember
  2929. {
  2930.     my $self = shift;
  2931.     my $name = shift;
  2932.     if ( $name eq $self->fileName() and -r $name )
  2933.     {
  2934.         return AZ_OK;
  2935.     }
  2936.     else
  2937.     {
  2938.         return $self->SUPER::extractToFileNamed( $name, @_ );
  2939.     }
  2940. }
  2941.  
  2942. =back
  2943.  
  2944. =head1 Archive::Zip::ZipFileMember methods
  2945.  
  2946. The Archive::Zip::ZipFileMember class represents members that have
  2947. been read from external zip files.
  2948.  
  2949. =over 4
  2950.  
  2951. =cut
  2952.  
  2953. # ----------------------------------------------------------------------
  2954. # class Archive::Zip::ZipFileMember
  2955. # This represents a member in an existing zip file on disk.
  2956. # ----------------------------------------------------------------------
  2957.  
  2958. package Archive::Zip::ZipFileMember;
  2959. use vars qw( @ISA );
  2960. @ISA = qw ( Archive::Zip::FileMember );
  2961.  
  2962. BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES :PKZIP_CONSTANTS
  2963.     :UTILITY_METHODS ) }
  2964.  
  2965. # Create a new Archive::Zip::ZipFileMember
  2966. # given a filename and optional open file handle
  2967. sub _newFromZipFile    # Archive::Zip::ZipFileMember
  2968. {
  2969.     my $class = shift;
  2970.     my $fh = shift;
  2971.     my $externalFileName = shift;
  2972.     my $self = $class->new(
  2973.         'crc32' => 0,
  2974.         'diskNumberStart' => 0,
  2975.         'localHeaderRelativeOffset' => 0,
  2976.         'dataOffset' =>  0,    # localHeaderRelativeOffset + header length
  2977.         @_
  2978.      );
  2979.     $self->{'externalFileName'} = $externalFileName;
  2980.     $self->{'fh'} = $fh;
  2981.     return $self;
  2982. }
  2983.  
  2984. sub isDirectory    # Archive::Zip::FileMember
  2985. {
  2986.     my $self = shift;
  2987.     return ( substr( $self->fileName(), -1, 1 ) eq '/'
  2988.         and $self->uncompressedSize() == 0 );
  2989. }
  2990.  
  2991. # Because I'm going to delete the file handle, read the local file
  2992. # header if the file handle is seekable. If it isn't, I assume that
  2993. # I've already read the local header.
  2994. # Return ( $status, $self )
  2995.  
  2996. sub _become    # Archive::Zip::ZipFileMember
  2997. {
  2998.     my $self = shift;
  2999.     my $newClass = shift;
  3000.     return $self if ref( $self ) eq $newClass;
  3001.  
  3002.     my $status = AZ_OK;
  3003.  
  3004.     if ( _isSeekable( $self->fh() ) )
  3005.     {
  3006.         my $here = $self->fh()->tell();
  3007.         $status = $self->fh()->seek(
  3008.             $self->localHeaderRelativeOffset() + SIGNATURE_LENGTH,
  3009.             IO::Seekable::SEEK_SET );
  3010.         if ( ! $status )
  3011.         {
  3012.             $self->fh()->seek( $here );
  3013.             _ioError( "seeking to local header" );
  3014.             return $self;
  3015.         }
  3016.         $self->_readLocalFileHeader();
  3017.         $self->fh()->seek( $here, IO::Seekable::SEEK_SET );
  3018.     }
  3019.  
  3020.     delete( $self->{'diskNumberStart'} );
  3021.     delete( $self->{'localHeaderRelativeOffset'} );
  3022.     delete( $self->{'dataOffset'} );
  3023.  
  3024.     return $self->SUPER::_become( $newClass );
  3025. }
  3026.  
  3027. #--------------------------------
  3028.  
  3029. =item diskNumberStart()
  3030.  
  3031. Returns the disk number that my local header resides
  3032. in. Had better be 0.
  3033.  
  3034. =cut
  3035.  
  3036. sub diskNumberStart    # Archive::Zip::ZipFileMember
  3037. { shift->{'diskNumberStart'} }
  3038.  
  3039. #--------------------------------
  3040.  
  3041. =item localHeaderRelativeOffset()
  3042.  
  3043. Returns the offset into the zip file where my local header is.
  3044.  
  3045. =cut
  3046.  
  3047. sub localHeaderRelativeOffset    # Archive::Zip::ZipFileMember
  3048. { shift->{'localHeaderRelativeOffset'} }
  3049.  
  3050. #--------------------------------
  3051.  
  3052. =item dataOffset()
  3053.  
  3054. Returns the offset from the beginning of the zip file to
  3055. my data.
  3056.  
  3057. =cut
  3058.  
  3059. sub dataOffset    # Archive::Zip::ZipFileMember
  3060. { shift->{'dataOffset'} }
  3061.  
  3062. # Skip local file header, updating only extra field stuff.
  3063. # Assumes that fh is positioned before signature.
  3064. sub _skipLocalFileHeader    # Archive::Zip::ZipFileMember
  3065. {
  3066.     my $self = shift;
  3067.     my $header;
  3068.     $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH )
  3069.         or return _ioError( "reading local file header" );
  3070.     my $fileNameLength;
  3071.     my $extraFieldLength;
  3072.     (    undef,     # $self->{'versionNeededToExtract'},
  3073.         undef,    # $self->{'bitFlag'},
  3074.         undef,    # $self->{'compressionMethod'},
  3075.         undef,    # $self->{'lastModFileDateTime'},
  3076.         undef,    # $crc32,
  3077.         undef,    # $compressedSize,
  3078.         undef,    # $uncompressedSize,
  3079.         $fileNameLength,
  3080.         $extraFieldLength ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
  3081.  
  3082.     if ( $fileNameLength )
  3083.     {
  3084.         $self->fh()->seek( $fileNameLength, IO::Seekable::SEEK_CUR )
  3085.             or return _ioError( "skipping local file name" );
  3086.     }
  3087.  
  3088.     if ( $extraFieldLength )
  3089.     {
  3090.         $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength )
  3091.             or return _ioError( "reading local extra field" );
  3092.     }
  3093.  
  3094.     $self->{'dataOffset'} = $self->fh()->tell();
  3095.  
  3096.     return AZ_OK;
  3097. }
  3098.  
  3099. # Read from a local file header into myself. Returns AZ_OK if successful.
  3100. # Assumes that fh is positioned after signature.
  3101. # Note that crc32, compressedSize, and uncompressedSize will be 0 if
  3102. # GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag.
  3103.  
  3104. sub _readLocalFileHeader    # Archive::Zip::ZipFileMember
  3105. {
  3106.     my $self = shift;
  3107.     my $header;
  3108.     $self->fh()->read( $header, LOCAL_FILE_HEADER_LENGTH )
  3109.         or return _ioError( "reading local file header" );
  3110.     my $fileNameLength;
  3111.     my $crc32;
  3112.     my $compressedSize;
  3113.     my $uncompressedSize;
  3114.     my $extraFieldLength;
  3115.     (    $self->{'versionNeededToExtract'},
  3116.         $self->{'bitFlag'},
  3117.         $self->{'compressionMethod'},
  3118.         $self->{'lastModFileDateTime'},
  3119.         $crc32,
  3120.         $compressedSize,
  3121.         $uncompressedSize,
  3122.         $fileNameLength,
  3123.         $extraFieldLength ) = unpack( LOCAL_FILE_HEADER_FORMAT, $header );
  3124.  
  3125.     if ( $fileNameLength )
  3126.     {
  3127.         my $fileName;
  3128.         $self->fh()->read( $fileName, $fileNameLength )
  3129.             or return _ioError( "reading local file name" );
  3130.         $self->fileName( $fileName );
  3131.     }
  3132.  
  3133.     if ( $extraFieldLength )
  3134.     {
  3135.         $self->fh()->read( $self->{'localExtraField'}, $extraFieldLength )
  3136.             or return _ioError( "reading local extra field" );
  3137.     }
  3138.  
  3139.     $self->{'dataOffset'} = $self->fh()->tell();
  3140.  
  3141.     # Don't trash these fields from the CD if we already have them.
  3142.     if ( not $self->hasDataDescriptor() )
  3143.     {
  3144.         $self->{'crc32'} = $crc32;
  3145.         $self->{'compressedSize'} = $compressedSize;
  3146.         $self->{'uncompressedSize'} = $uncompressedSize;
  3147.     }
  3148.  
  3149.     # We ignore data descriptors (we don't read them,
  3150.     # and we compute elsewhere whether we need to write them ).
  3151.     # And, we have the necessary data from the CD header.
  3152.     # So mark this entry as not having a data descriptor.
  3153.     $self->hasDataDescriptor( 0 );
  3154.  
  3155.     return AZ_OK;
  3156. }
  3157.  
  3158. # This will read the data descriptor, which is at the end of files that have
  3159. # GPBF_HAS_DATA_DESCRIPTOR_MASK set in their bitFlag.
  3160. # Note that you have to seek to the end of the compressed file to find this to
  3161. # read.
  3162. # sub _readDataDescriptor
  3163. # {
  3164. #     my $self = shift;
  3165. #     my $header;
  3166. #     $self->fh()->read( $header, DATA_DESCRIPTOR_LENGTH )
  3167. #         or return _ioError( "reading data descriptor" );
  3168. #     (
  3169. #         $self->{'crc32'},
  3170. #         $self->{'compressedSize'},
  3171. #         $self->{'uncompressedSize'}
  3172. #      ) = unpack( DATA_DESCRIPTOR_FORMAT, $header );
  3173. #     return AZ_OK;
  3174. # }
  3175.  
  3176. # Read a Central Directory header. Return AZ_OK on success.
  3177. # Assumes that fh is positioned right after the signature.
  3178.  
  3179. sub _readCentralDirectoryFileHeader    # Archive::Zip::ZipFileMember
  3180. {
  3181.     my $self = shift;
  3182.     my $fh = $self->fh();
  3183.     my $header = '';
  3184.     $fh->read( $header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH )
  3185.         or return _ioError( "reading central dir header" );
  3186.     my ( $fileNameLength, $extraFieldLength, $fileCommentLength );
  3187.     (
  3188.         $self->{'versionMadeBy'},
  3189.         $self->{'fileAttributeFormat'},
  3190.         $self->{'versionNeededToExtract'},
  3191.         $self->{'bitFlag'},
  3192.         $self->{'compressionMethod'},
  3193.         $self->{'lastModFileDateTime'},
  3194.         $self->{'crc32'},
  3195.         $self->{'compressedSize'},
  3196.         $self->{'uncompressedSize'},
  3197.         $fileNameLength,
  3198.         $extraFieldLength,
  3199.         $fileCommentLength,
  3200.         $self->{'diskNumberStart'},
  3201.         $self->{'internalFileAttributes'},
  3202.         $self->{'externalFileAttributes'},
  3203.         $self->{'localHeaderRelativeOffset'}
  3204.      ) = unpack( CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header );
  3205.  
  3206.     if ( $fileNameLength )
  3207.     {
  3208.         $fh->read( $self->{'fileName'}, $fileNameLength )
  3209.             or return _ioError( "reading central dir filename" );
  3210.     }
  3211.     if ( $extraFieldLength )
  3212.     {
  3213.         $fh->read( $self->{'cdExtraField'}, $extraFieldLength )
  3214.             or return _ioError( "reading central dir extra field" );
  3215.     }
  3216.     if ( $fileCommentLength )
  3217.     {
  3218.         $fh->read( $self->{'fileComment'}, $fileCommentLength )
  3219.             or return _ioError( "reading central dir file comment" );
  3220.     }
  3221.  
  3222.     $self->desiredCompressionMethod( $self->compressionMethod() );
  3223.  
  3224.     return AZ_OK;
  3225. }
  3226.  
  3227. sub rewindData    # Archive::Zip::ZipFileMember
  3228. {
  3229.     my $self = shift;
  3230.  
  3231.     my $status = $self->SUPER::rewindData( @_ );
  3232.     return $status if $status != AZ_OK;
  3233.  
  3234.     return AZ_IO_ERROR if ! $self->fh();
  3235.  
  3236.     $self->fh()->clearerr();
  3237.  
  3238.     # Seek to local file header.
  3239.     # The only reason that I'm doing this this way is that the extraField
  3240.     # length seems to be different between the CD header and the LF header.
  3241.     $self->fh()->seek( $self->localHeaderRelativeOffset() + SIGNATURE_LENGTH,
  3242.         IO::Seekable::SEEK_SET )
  3243.             or return _ioError( "seeking to local header" );
  3244.  
  3245.     # skip local file header
  3246.     $status = $self->_skipLocalFileHeader();
  3247.     return $status if $status != AZ_OK;
  3248.  
  3249.     # Seek to beginning of file data
  3250.     $self->fh()->seek( $self->dataOffset(), IO::Seekable::SEEK_SET )
  3251.         or return _ioError( "seeking to beginning of file data" );
  3252.  
  3253.     return AZ_OK;
  3254. }
  3255.  
  3256. # Return bytes read. Note that first parameter is a ref to a buffer.
  3257. # my $data;
  3258. # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
  3259. sub _readRawChunk    # Archive::Zip::ZipFileMember
  3260. {
  3261.     my ( $self, $dataRef, $chunkSize ) = @_;
  3262.     return ( 0, AZ_OK )
  3263.         if ( ! $chunkSize );
  3264.     my $bytesRead = $self->fh()->read( $$dataRef, $chunkSize )
  3265.         or return ( 0, _ioError( "reading data" ) );
  3266.     return ( $bytesRead, AZ_OK );
  3267. }
  3268.  
  3269. # ----------------------------------------------------------------------
  3270. # class Archive::Zip::StringMember ( concrete )
  3271. # A Zip member whose data lives in a string
  3272. # ----------------------------------------------------------------------
  3273.  
  3274. package Archive::Zip::StringMember;
  3275. use vars qw( @ISA );
  3276. @ISA = qw ( Archive::Zip::Member );
  3277.  
  3278. BEGIN { use Archive::Zip qw( :CONSTANTS :ERROR_CODES ) }
  3279.  
  3280. # Create a new string member. Default is COMPRESSION_STORED.
  3281. # Can take a ref to a string as well.
  3282. sub _newFromString    # Archive::Zip::StringMember
  3283. {
  3284.     my $class = shift;
  3285.     my $string = shift;
  3286.     my $name = shift;
  3287.     my $self = $class->new( @_ );
  3288.     $self->contents( $string );
  3289.     $self->fileName( $name ) if defined( $name );
  3290.     # Set the file date to now
  3291.     $self->setLastModFileDateTimeFromUnix( time() );
  3292.     $self->unixFileAttributes( $self->DEFAULT_FILE_PERMISSIONS );
  3293.     return $self;
  3294. }
  3295.  
  3296. sub _become    # Archive::Zip::StringMember
  3297. {
  3298.     my $self = shift;
  3299.     my $newClass = shift;
  3300.     return $self if ref( $self ) eq $newClass;
  3301.     delete( $self->{'contents'} );
  3302.     return $self->SUPER::_become( $newClass );
  3303. }
  3304.  
  3305. # Get or set my contents. Note that we do not call the superclass
  3306. # version of this, because it calls us.
  3307. sub contents    # Archive::Zip::StringMember
  3308. {
  3309.     my $self = shift;
  3310.     my $string = shift;
  3311.     if ( defined( $string ) )
  3312.     {
  3313.         $self->{'contents'} = ( ref( $string ) eq 'SCALAR' )
  3314.             ? $$string
  3315.             : $string;
  3316.         $self->{'uncompressedSize'}
  3317.             = $self->{'compressedSize'}
  3318.             = length( $self->{'contents'} );
  3319.         $self->{'compressionMethod'} = COMPRESSION_STORED;
  3320.     }
  3321.     return $self->{'contents'};
  3322. }
  3323.  
  3324. # Return bytes read. Note that first parameter is a ref to a buffer.
  3325. # my $data;
  3326. # my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
  3327. sub _readRawChunk    # Archive::Zip::StringMember
  3328. {
  3329.     my ( $self, $dataRef, $chunkSize ) = @_;
  3330.     $$dataRef = substr( $self->contents(), $self->_readOffset(), $chunkSize );
  3331.     return ( length( $$dataRef ), AZ_OK );
  3332. }
  3333.  
  3334. 1;
  3335. __END__
  3336.  
  3337. =back
  3338.  
  3339. =head1 AUTHOR
  3340.  
  3341. Ned Konz, perl@bike-nomad.com
  3342.  
  3343. =head1 COPYRIGHT
  3344.  
  3345. Copyright (c) 2000 Ned Konz. All rights reserved.  This program is free
  3346. software; you can redistribute it and/or modify it under the same terms
  3347. as Perl itself.
  3348.  
  3349. =head1 SEE ALSO
  3350.  
  3351. L<Compress::Zlib>
  3352.  
  3353. =cut
  3354.  
  3355. # vim: ts=4 sw=4 columns=80
  3356.